theory Modules
imports Lang_Typed
keywords "moduletype" :: thy_decl
begin

section {* Module types and modules *}

datatype module_type = ModuleType
 "(id0,module_type) map" (* args *)
 "(id,procedure_type) map" (* procedure types *)
fun mt_proctypes :: "module_type \<Rightarrow> (id,procedure_type) map" where
  "mt_proctypes (ModuleType _ pt) = pt"
fun mt_args :: "module_type \<Rightarrow> (id0,module_type) map" where
  "mt_args (ModuleType a _) = a"

fun module_type_map_to_proc_env :: "(id0,module_type) map \<Rightarrow> (id,procedure_type)map" where
  "module_type_map_to_proc_env T [] = None"
| "module_type_map_to_proc_env T (modul#path) =
    (case T modul of None \<Rightarrow> None
                   | Some (ModuleType args' procs') \<Rightarrow> procs' path)"
lemma module_type_map_to_proc_env_empty:
  "module_type_map_to_proc_env empty = empty"
  by (rule ext, rule list.induct, auto)

definition module_type_proc_env :: "module_type \<Rightarrow> (id,procedure_type)map" where
  "module_type_proc_env mt = module_type_map_to_proc_env (mt_args mt)"

record module_rep =
  mr_module_args :: "(id0,module_type) map"
  mr_procs :: "(id,procedure_rep) map"
(* TODO variables *)

locale test =
  fixes x::"'a set"
begin
  typedef 'b x = "{undefined::'b}" by auto
  print_theorems
end

definition well_typed_module :: "module_rep \<Rightarrow> bool" where
  "well_typed_module m == finite(dom(mr_procs m)) \<and> finite(dom(mr_module_args m))
  \<and> (\<forall>p\<in>ran(mr_procs m). well_typed_proc' (module_type_map_to_proc_env(mr_module_args m)) p)"

typedef module = "{m. well_typed_module m}"
  by (rule exI[where x="\<lparr> mr_module_args=empty, mr_procs=empty \<rparr>"], auto simp: well_typed_module_def)
definition "get_proc_in_module M name = mr_procs (Rep_module M) name"

fun has_module_type' :: "module_rep \<Rightarrow> module_type \<Rightarrow> bool" where
  "has_module_type' modul (ModuleType argsT procsT) =
   (well_typed_module modul \<and>
    mr_module_args modul = argsT \<and>
   (\<forall>name. case (procsT name, mr_procs modul name) of
      (Some procT, Some p) \<Rightarrow> (proctype_of p = procT)
    | (Some procT, None) \<Rightarrow> False
    | (None, _) \<Rightarrow> True))"

definition "ignore x y == y"

definition "has_module_type M == has_module_type' (Rep_module M)"

definition "is_closed_module modul == mr_module_args modul = empty"
fun is_closed_module_type where
 "is_closed_module_type (ModuleType args _) = (args = empty)"

lemma module_proc_type:
  assumes name: "name \<in> dom procT"
  assumes type: "has_module_type M (ModuleType argT procT)"
  obtains p where "get_proc_in_module M name = Some p"
            and "well_typed_proc' (module_type_map_to_proc_env argT) p"
            and "Some (proctype_of p) = procT name"
proof -
  let ?M = "Rep_module M"
  have h: "case (procT name, mr_procs ?M name) of
      (Some procT, Some p) \<Rightarrow> (proctype_of p = procT)
    | (Some procT, None) \<Rightarrow> False
    | (None, _) \<Rightarrow> True"
  by (metis type has_module_type'.simps has_module_type_def)
  def p == "the (get_proc_in_module M name)"

  have "get_proc_in_module M name = Some p"
    by (smt2 h name domIff p_def get_proc_in_module_def option.case_eq_if option.collapse prod.case)
  moreover have "well_typed_proc' (module_type_map_to_proc_env argT) p"
  proof -
    have ran: "p \<in> ran (mr_procs (Rep_module M))"
      by (metis (mono_tags) p_def curryI curry_split domD get_proc_in_module_def h name option.collapse option.simps(4) option.simps(5) ranI)
    hence "well_typed_proc' (module_type_map_to_proc_env (mr_module_args ?M)) p"
      using type by (auto simp: well_typed_module_def has_module_type_def)
    also have "mr_module_args ?M = argT"
      using type by (auto simp: has_module_type_def)
    ultimately show ?thesis by simp
  qed
  moreover have "Some (proctype_of p) = procT name"
    by (smt2 calculation(1) domIff get_proc_in_module_def h name not_None_eq option.simps(5) prod.case)
  ultimately show ?thesis ..
qed

(* TODO useful? *)
lemma todo_name:
  fixes modul modulT name
  assumes modtype: "has_module_type' modul modulT"
  assumes proctype: "mt_proctypes modulT name = Some (procedure_type TYPE(('a::procargs,'b::prog_type)procedure))"
  assumes p_def: "mr_procs modul name = Some p"
  assumes closed: "is_closed_module_type modulT"
  shows "mk_procedure_untyped (mk_procedure_typed p::('a,'b)procedure) = p"
proof -
  obtain argT procT where modulT_def: "modulT = ModuleType argT procT" by (cases modulT)
  from proctype have name: "name \<in> dom procT" unfolding modulT_def by auto
  have Abs: "Rep_module (Abs_module modul) = modul"
    apply (rule Abs_module_inverse)
    using modtype unfolding modulT_def by simp
  have type: "has_module_type (Abs_module modul) (ModuleType argT procT)"
    using modtype unfolding has_module_type_def modulT_def Abs .
  with name obtain p' where "get_proc_in_module (Abs_module modul) name = Some p'"
           and wtp': "well_typed_proc' (module_type_map_to_proc_env argT) p'"
           and procT: "Some (proctype_of p') = procT name"
    by (rule module_proc_type, auto)
  with p_def have "p'=p"
    unfolding get_proc_in_module_def Abs by simp
  from closed have empty: "module_type_map_to_proc_env argT = empty"
    by (simp add: modulT_def module_type_map_to_proc_env_empty)
  have wtp: "well_typed_proc' empty p"
    using wtp' `p'=p` empty by simp
  obtain body args ret where p_def2: "p=Proc body args ret"
    by (metis wtp option.distinct(1) procedure_rep.exhaust well_typed_proc'.simps(1))
  have body: "well_typed body" using wtp unfolding p_def2 by simp
  have ret: "eu_type ret = Type TYPE('b)"
    using procT proctype unfolding `p'=p` p_def2 modulT_def procedure_type_def by simp
  have args: "args \<in> procargvars TYPE('a)"
    by (metis Abs get_proc_in_module_def has_module_type_def modtype modulT_def module_proc_type mt_proctypes.simps name option.inject p_def p_def2 procedure_type_procargvars proctype)
  from body args ret show "mk_procedure_untyped (mk_procedure_typed p::('a,'b)procedure) = p"
    unfolding p_def2 by (rule mk_procedure_typed_inverse)
qed

lemma module_proc_notref:
  assumes type: "has_module_type M (ModuleType empty procT)"
  assumes get: "get_proc_in_module M name = Some (ProcRef x y z)"
  shows False
proof -
  let ?M = "Rep_module M"
  let ?p = "ProcRef x y z"
  have wt: "well_typed_module ?M"
    by (metis Rep_module mem_Collect_eq)
  have args_empty: "mr_module_args ?M = empty"
    by (metis type has_module_type'.simps has_module_type_def)
  from get have ran: "?p\<in>ran (mr_procs (Rep_module M))"
    unfolding get_proc_in_module_def by (rule ranI)
  have "well_typed_proc' empty (ProcRef x y z)"
    using wt unfolding well_typed_module_def
    unfolding module_type_map_to_proc_env_empty[symmetric]
    by (metis (poly_guards_query) has_module_type'.simps has_module_type_def ran type)
  thus ?thesis by simp
qed

(* TODO move *)
fun substitute_procs :: "(id,procedure_rep)map \<Rightarrow> program_rep \<Rightarrow> program_rep" where
  "substitute_procs m Skip = Skip"
fun substitute_procs_in_proc :: "(id,procedure_rep)map \<Rightarrow> procedure_rep \<Rightarrow> procedure_rep" where
  "substitute_procs_in_proc m (Proc body args ret) = Proc (substitute_procs m body) args ret"
| "substitute_procs_in_proc m (ProcRef name args ret) = the (m name)"

(* TODO move *)
lemma substitute_procs_in_proc_welltyped:
  assumes "well_typed_proc' ((map_option proctype_of) o m) p"
  assumes "\<forall>p'\<in>ran(m). well_typed_proc' empty p'"
  shows "well_typed_proc' empty (substitute_procs_in_proc m p)"
sorry

(* TODO move *)
lemma substitute_procs_in_proc_type:
  assumes "well_typed_proc' ((map_option proctype_of) o m) p"
  shows "proctype_of (substitute_procs_in_proc m p) = proctype_of p"
proof (cases p)
case (Proc body args ret)
  thus ?thesis by simp
next case (ProcRef name argsT retT)
  note p = this
  with assms obtain p' where p': "m name = Some p'"
    and p'_type: "proctype_of p' = \<lparr>pt_argtypes = argsT, pt_returntype = retT\<rparr>"
    by auto
  show ?thesis
    by (simp add: p p' p'_type)
qed
(* TODO move *)
(* closed_program p \<equiv> p does not contain ProcRef's *)
fun closed_program :: "program_rep \<Rightarrow> bool" where
  "closed_program Skip = True"
| "closed_program (Assign v e) = True"
| "closed_program (Sample v e) = True"
| "closed_program (Seq c d) = (closed_program c \<and> closed_program d)"
| "closed_program (CallProc v (Proc body args ret) a) = closed_program body"
| "closed_program (CallProc v (ProcRef name argsT retT) a) = False"
| "closed_program (While e p) = closed_program p"
| "closed_program (IfTE e p1 p2) = (closed_program p1 \<and> closed_program p2)"
print_theorems

(* TODO move *)
lemma closed_program_well_typed: "closed_program p \<Longrightarrow> well_typed' E p \<Longrightarrow> well_typed' E' p"
  by (induction rule: closed_program.induct, auto)

(* TODO move *)
lemma well_typed_proc_closed:
  assumes "well_typed_proc' empty (Proc body args ret)"
  shows "closed_program body"
proof -
  from assms have "well_typed body" by auto
  thus "closed_program body"
    by (induction rule: closed_program.induct, simp_all)
qed

definition "get_proc_in_module' name modul = mk_procedure_typed (the (mr_procs (Rep_module modul) name))"
definition "get_proc_in_module'' name mk_map modul args = mk_procedure_typed
  (substitute_procs_in_proc (mk_map args) (the (mr_procs (Rep_module modul) name)))"

lemma get_proc_in_module'':
  fixes M::module and mk_map::"'e\<Rightarrow>(id,procedure_rep)map" and procT name
  assumes type: "has_module_type M (ModuleType argsT procT)"
  assumes mk_map_t: "map_option proctype_of \<circ> mk_map args = module_type_proc_env (ModuleType argsT procT)"
  assumes wt_mk_map: "\<forall>p'\<in>ran (mk_map args). well_typed_proc' Map.empty p'"
  assumes procT: "procT name = Some (procedure_type TYPE(('a::procargs,'b::prog_type)procedure))"
  shows "map_option (substitute_procs_in_proc (mk_map args)) (get_proc_in_module M name) =
    Some (mk_procedure_untyped (get_proc_in_module'' name mk_map M args::('a,'b)procedure))"
proof -
  def E == "module_type_map_to_proc_env argsT"
  obtain p where get_proc: "get_proc_in_module M name = Some p"
             and wt_p: "well_typed_proc' E p"
             and procT_name: "Some (proctype_of p) = procT name"
    unfolding E_def using module_proc_type type procT by blast

  hence p_def: "p = the (mr_procs (Rep_module M) name)"
    unfolding get_proc_in_module_def by auto

  have p_type: "proctype_of p = procedure_type TYPE(('a::procargs,'b::prog_type)procedure)"
    by (metis procT_name option.sel procT)

  have subst_p_type: "proctype_of (substitute_procs_in_proc (mk_map args) p) = procedure_type TYPE(('a::procargs,'b::prog_type)procedure)"
    apply (fold p_type, rule substitute_procs_in_proc_type)
    by (metis E_def mk_map_t module_type_proc_env_def mt_args.simps wt_p)

  have wt_subst_p: "well_typed_proc' empty (substitute_procs_in_proc (mk_map args) p)"
    apply (rule substitute_procs_in_proc_welltyped)
    apply (metis E_def mk_map_t module_type_proc_env_def mt_args.simps wt_p)
    by (fact wt_mk_map)

  obtain body pargs ret where
    subst_p: "substitute_procs_in_proc (mk_map args) p = Proc body pargs ret"
  proof (cases p)
  case (Proc body' pargs ret)
    note p = this
    def body == "substitute_procs (mk_map args) body'"
    have subst_p: "substitute_procs_in_proc (mk_map args) p = Proc body pargs ret"
      unfolding p body_def by simp
    with that show ?thesis by auto
  next case (ProcRef name pargsT retT)
    note p = this
    obtain p' where p': "mk_map args name = Some p'"
    proof -
      from mk_map_t have "(map_option proctype_of \<circ> mk_map args) name = module_type_proc_env (ModuleType argsT procT) name"
        by simp
      hence none: "mk_map args name = None \<Longrightarrow> module_type_proc_env (ModuleType argsT procT) name = None"
        by simp
      have "module_type_proc_env (ModuleType argsT procT) name \<noteq> None"
        using wt_p by (simp add: p E_def module_type_proc_env_def)
      with none and that show ?thesis by auto
    qed
    obtain body args' ret where "p' = Proc body args' ret"
    proof (cases p')
    case (Proc body args' ret) with that show ?thesis by auto
    next case (ProcRef name argsT retT)
      note thecase = this
      from p' have "p'\<in>ran (mk_map args)" by (rule ranI)
      with wt_mk_map have "well_typed_proc' Map.empty p'" by simp
      thus ?thesis unfolding thecase by auto
    qed
    hence subst_p: "substitute_procs_in_proc (mk_map args) p = Proc body args' ret"
      by (simp add: p p')
    with that show ?thesis by auto
  qed
  from wt_subst_p have wt_body: "well_typed' empty body"
    unfolding subst_p by simp
  have closed: "closed_program body"
    apply (rule well_typed_proc_closed[where args=pargs and ret=ret])
    apply (fold subst_p)
    by (fact wt_subst_p)

  show "map_option (substitute_procs_in_proc (mk_map args)) (get_proc_in_module M name) =
         Some (mk_procedure_untyped (get_proc_in_module'' name mk_map M args::('a,'b)procedure))"
     unfolding get_proc_in_module''_def p_def[symmetric] subst_p
       apply (subst mk_procedure_typed_inverse)
       (* well_typed body *)
       apply (rule closed_program_well_typed, fact closed, fact wt_body)
       (* pargs \<in> procargvars TYPE('a) *)
       using subst_p_type[unfolded subst_p] wt_subst_p[unfolded subst_p]
       unfolding p_def apply (rule procedure_type_procargvars)
       (* eu_type ret = Type TYPE('b) *)
       using subst_p_type subst_p apply (simp add: p_def procedure_type_def)
       (* get_proc_in_module M name = Some (Proc body pargs ret) *)
       apply simp by (metis get_proc subst_p)
qed

lemma get_proc_in_module':
  fixes M::module and procT name
  assumes type: "has_module_type M (ModuleType empty procT)"
  assumes procT: "procT name = Some (procedure_type TYPE(('a::procargs,'b::prog_type)procedure))"
  shows "get_proc_in_module M name =
    Some (mk_procedure_untyped (get_proc_in_module' name M::('a,'b)procedure))"
proof (cases "the (mr_procs (Rep_module M) name)")
case (ProcRef x y z)
  note procref = this
  show ?thesis apply (rule FalseE)
    by (metis domI get_proc_in_module_def module_proc_type module_proc_notref option.sel procT procref type)
next
case (Proc body args ret)
  note proc = this
  obtain p where get_proc: "get_proc_in_module M name = Some p"
             and wt_p_0: "well_typed_proc' (module_type_map_to_proc_env empty) p"
             and procT_name: "Some (proctype_of p) = procT name"
    using module_proc_type type procT by blast
  with proc have p_def: "p = (Proc body args ret)"
    unfolding get_proc_in_module_def by auto
  have empty_args: "mr_module_args (Rep_module M) = empty"
    by (metis has_module_type'.simps has_module_type_def type)
  (*  have ran: "Proc body args ret \<in> ran (mr_procs (Rep_module M))"
    by (metis (full_types) domI get_proc_in_module_def module_proc_type option.collapse option.distinct(1) proc procT ranI type)  *)
  (*  have "well_typed_module (Rep_module M)"
    by (metis Rep_module mem_Collect_eq)  *)

  with wt_p_0 have wt_p: "well_typed_proc' empty p"
    unfolding module_type_map_to_proc_env_empty by simp

  have p_type: "proctype_of p = procedure_type TYPE(('a::procargs,'b::prog_type)procedure)"
    by (metis procT_name option.sel procT)

  show "get_proc_in_module M name =
       Some (mk_procedure_untyped (get_proc_in_module' name M::('a,'b)procedure))"
    unfolding proc get_proc_in_module'_def
    apply (subst mk_procedure_typed_inverse)
    (* well_typed body *)
    using wt_p p_def apply simp
    (* args \<in> procargvars TYPE('a) *)
    using p_type wt_p unfolding p_def apply (rule procedure_type_procargvars)
    (* eu_type ret = Type TYPE('b) *)
    using p_type apply (simp add: p_def procedure_type_def)
    (* get_proc_in_module M name = Some (Proc body args ret) *)
    by (simp add: get_proc p_def)
qed

lemma module_type_nonempty:
  assumes "finite (dom (mt_proctypes mT))"
  assumes "finite (dom (mt_args mT))"
  shows "\<exists>m. has_module_type m mT"
proof -
  obtain argT procT where mT_def: "mT = ModuleType argT procT" by (cases mT)
  let ?some = "\<lambda>t p. well_typed_proc' (module_type_map_to_proc_env argT) p \<and> proctype_of p = t"
  def procs == "(\<lambda>t. Some (SOME p. ?some t p)) \<circ>\<^sub>m procT"
  have some: "\<And>t. ?some t (SOME p. ?some t p)"
    by (rule someI_ex, rule proctype_nonempty)
  hence procs_good: "\<And>name t.
    procT name = Some t \<Longrightarrow> case procs name of None \<Rightarrow> False | Some p \<Rightarrow> proctype_of p = t"
    unfolding procs_def by auto
  def m == "Abs_module \<lparr> mr_module_args=argT, mr_procs=procs \<rparr>"

  have wt_mod: "well_typed_module \<lparr> mr_module_args=argT, mr_procs=procs \<rparr>"
    unfolding well_typed_module_def
    apply (rule, smt2 assms(1) domIff mT_def map_comp_simps(1) module_rep.select_convs(2) mt_proctypes.simps procs_def rev_finite_subset subsetI)
    apply (rule, metis assms(2) mT_def module_rep.select_convs(1) mt_args.simps)
    apply simp
    by (smt2 map_comp_Some_iff mem_Collect_eq option.sel procs_def proctype_nonempty ran_def someI_ex)

  hence rep: "Rep_module m = \<lparr> mr_module_args=argT, mr_procs=procs \<rparr>"
    unfolding m_def by (subst Abs_module_inverse, simp_all)

  have "has_module_type m mT"
    unfolding has_module_type_def mT_def apply (simp add: rep wt_mod)
    apply (rule, case_tac "procT name", auto)
    using procs_good by auto
  thus "\<exists>m. has_module_type m mT" ..
qed

ML_file "modules.ML"

section {* Some tests (TODO: remove) *}

term "''x'' = (a::_::prog_type)"

moduletype MT where
  a :: "(unit,int) procedure"
print_theorems
moduletype MT2(M:MT) where
  b :: "(unit,unit) procedure";
print_theorems

definition MT2_b_mk_map :: "(unit,int)procedure \<Rightarrow> (id,procedure_rep)map" where
  "MT2_b_mk_map \<equiv> (\<lambda>a. [[''M'',''a'']\<mapsto>mk_procedure_untyped a])"

thm MT_def

ML {*
fun define_module_mk_map lthy =
let val procs = [(["M","a"],@{typ "(unit,int)procedure"})
(*                 (["M","c"],@{typ "(int*unit,bool)procedure"}) *)
                 ]
    val mt_name = @{binding "MT2"}

    val mapT = @{typ "(id,procedure_rep) map"}
    fun body [] = (@{term "empty::(id,procedure_rep)map"},0)
      | body ((n1,t1)::rest) =
          let val (b,i) = body rest
              val n1' = HOLogic.mk_list @{typ "string"} (map HOLogic.mk_string n1)
              val p = Const(@{const_name mk_procedure_untyped},t1--> @{typ procedure_rep})$Bound i
              val b' = @{term "fun_upd::(id,procedure_rep)map=>id=>procedure_rep option=>(id,procedure_rep)map"}
                       $ b $ n1' $ (@{term "Some::_\<Rightarrow>procedure_rep option"} $ p)
          in
          (b',i+1)
          end
    val body = body procs |> fst
    fun name_to_id n = String.concatWith "_" n
    fun abs [] = @{term "\<lambda>_::unit. empty"}
      | abs [(n1,t1)] = Abs(name_to_id n1,t1,body)
      | abs [(n1,t1),(n2,t2)] =
          Const(@{const_name case_prod},(t1 --> t2 --> mapT) --> (HOLogic.mk_prodT(t1,t2) --> mapT)) $
          Abs(name_to_id n1,t1,Abs(name_to_id n2,t2,body))
      | abs ((n1,t1)::rest) =
          let val rest' = abs rest
              val restT = fastype_of rest'
              val (t2,t3) = restT |> dest_funT |> fst |> HOLogic.dest_prodT
          in
          Const(@{const_name case_prod},(t1-->restT) --> (HOLogic.mk_prodT(t1,HOLogic.mk_prodT(t2,t3))-->mapT)) $
          Abs(name_to_id n1,t1,abs rest)
          end
    val mk_map_def = abs procs
    val mk_map_name = Binding.qualified true "mk_map" mt_name
    val ((const,(_,thm)),lthy) = Local_Theory.define ((mk_map_name, NoSyn),
          ((Thm.def_binding mk_map_name,[]), mk_map_def)) lthy
in
@{print} (const,thm);
lthy
end;
*}
local_setup {*
define_module_mk_map
*}

thm MT2_b_mk_map_def MT2.mk_map_def

definition MT2_b :: "module \<Rightarrow> (unit,int)procedure \<Rightarrow> (unit,unit)procedure" where
  "MT2_b \<equiv> get_proc_in_module'' [''b''] MT2.mk_map"

(* TODO move *)
lemma proctype_mk_untyped [simp]:
  "proctype_of (mk_procedure_untyped (p::('a::procargs,'b::prog_type)procedure))
  = procedure_type TYPE(('a,'b)procedure)"
sorry

lemma MT2_b:
  fixes M and a::"(unit,int)procedure"
  assumes type:"has_module_type M MT2"
  shows "map_option (substitute_procs_in_proc [[''M'',''a'']\<mapsto>mk_procedure_untyped a]) (get_proc_in_module M [''b'']) =
       Some (mk_procedure_untyped (MT2_b M a))"
proof (unfold MT2_b_def MT2.mk_map_def, rule get_proc_in_module'')
  def argsT == "[''M'' \<mapsto> MT]" and procT == "[[''b''] \<mapsto> procedure_type TYPE((unit, unit) procedure)]"
  def mk_map == "\<lambda>a::(unit,int)procedure. [[''M'',''a'']\<mapsto>mk_procedure_untyped a]"
  have MT2_def: "MT2 == ModuleType argsT procT" unfolding MT2_def argsT_def procT_def.
  show "has_module_type M (ModuleType argsT procT)" by (fold MT2_def, fact type)
  show "map_option proctype_of \<circ> (mk_map a) = module_type_proc_env (ModuleType argsT procT)"
    unfolding mk_map_def argsT_def procT_def apply simp
    unfolding module_type_proc_env_def MT_def apply simp
    apply (rule ext, case_tac x, simp, simp)
    sorry
  show "\<forall>p'\<in>ran (mk_map a). well_typed_proc' Map.empty p'" sorry
  show "procT [''b''] = Some (procedure_type TYPE((unit,unit) procedure))" sorry
qed

abbreviation "xxx == Variable ''x'' :: int variable"
definition "mt2_b (a::(unit,int)procedure) \<equiv>
  proc() { xxx:=call a(); xxx:=call a(); return () }"

ML {* @{thm mt2_b_def} *}

definition "parametric_proc E mk_map (p::'e\<Rightarrow>('a::procargs,'b::prog_type)procedure) ==
   SOME p'. proctype_of p' = procedure_type TYPE(('a,'b)procedure) \<and> well_typed_proc' E p' \<and>
   (\<forall>a. mk_procedure_untyped (p a) = substitute_procs_in_proc (mk_map a) p')"
print_theorems

definition "parametric_proc_exists E mk_map (p::'e\<Rightarrow>('a::procargs,'b::prog_type)procedure) ==
   \<exists>p'. proctype_of p' = procedure_type TYPE(('a,'b)procedure) \<and> well_typed_proc' E p' \<and>
   (\<forall>a. mk_procedure_untyped (p a) = substitute_procs_in_proc (mk_map a) p')"

lemma parametric_proc_props:
  assumes ex:"parametric_proc_exists E mk_map (p::'e\<Rightarrow>('a::procargs,'b::prog_type)procedure)"
  defines "p' \<equiv> parametric_proc E mk_map p"
  shows "proctype_of p' = procedure_type TYPE(('a,'b)procedure)"
  and   "well_typed_proc' E p'"
  and   "\<And>a. mk_procedure_untyped (p a) = substitute_procs_in_proc (mk_map a) p'"
using someI_ex[OF ex[unfolded parametric_proc_exists_def]]
unfolding p'_def parametric_proc_def by metis+

definition "parametric_prog_exists E mk_map p ==
   \<exists>p'. well_typed' E p' \<and>
   (\<forall>a. mk_program_untyped (p a) = substitute_procs (mk_map a) p')"

lemma parametric_proc_exists_proc:
  fixes (* pbody :: "'e \<Rightarrow> program" and args::"'a::procargs procargvars" and ret::"'b::prog_type expression"
    and *) P :: "'e \<Rightarrow> ('a::procargs,'b::prog_type) procedure" and E::"(id,procedure_type) map"
    and mk_map :: "'e \<Rightarrow> (id,procedure_rep) map"
(*  defines "procT == procedure_type TYPE(('a,'b)procedure)" *)
(*  defines "P == \<lambda>a. \<lparr> p_body=pbody a, p_args=args, p_return=ret \<rparr> :: ('a,'b)procedure" *)
  assumes "parametric_prog_exists E mk_map (\<lambda>a. p_body (P a))"
(*  shows "\<exists>p. proctype_of p = procT \<and> well_typed_proc' E p \<and>
    (\<forall>a::'e. mk_procedure_untyped (P a) = substitute_procs_in_proc (mk_map a) p)"*)
  shows "parametric_proc_exists E mk_map P"

sorry

lemma parametric_prog_exists_seq:
  assumes "parametric_prog_exists E mk_map p1"
  assumes "parametric_prog_exists E mk_map p2"
  shows "parametric_prog_exists E mk_map (\<lambda>a. seq (p1 a) (p2 a))"
sorry

lemma parametric_prog_exists_callproc:
  assumes "parametric_proc_exists E mk_map p"
  shows "parametric_prog_exists E mk_map (\<lambda>a. callproc v (p a) args)"
sorry

lemma parametric_proc_exists_ref: (* TODO: generalize to tuples a *)
  assumes "E name = Some \<lparr>pt_argtypes = procargtypes TYPE('a::procargs), pt_returntype = Type TYPE('b::prog_type)\<rparr>"
  assumes "\<And>a. mk_map a name = Some (mk_procedure_untyped a)"
  shows "parametric_proc_exists E mk_map (\<lambda>a. a :: ('a,'b)procedure)"
unfolding parametric_proc_exists_def procedure_type_def
apply (rule_tac x="ProcRef name ?arg ?ret" in exI)
using assms by auto

lemmas parametric_prog_existsI = parametric_prog_exists_callproc parametric_prog_exists_seq
  parametric_proc_exists_proc (* Doesn't automate well: parametric_proc_exists_ref *)

lemma test1:
  defines "E == module_type_proc_env MT2"
  defines "mk_map a == ([[''M'',''a'']\<mapsto>mk_procedure_untyped a])"
  defines "p' == parametric_proc E mk_map mt2_b"
(*  shows "proctype_of p' = procedure_type TYPE((unit,int)procedure)"
  and   "well_typed_proc' E p'" *)
  shows   "\<And>a. mk_procedure_untyped (mt2_b a) = substitute_procs_in_proc (mk_map a) p'"
unfolding p'_def
apply (rule parametric_proc_props)
  unfolding mt2_b_def
  unfolding E_def MT2_def module_type_proc_env_def MT_def procedure_type_def mk_map_def
  apply (rule parametric_proc_exists_proc, simp)
  apply (rule parametric_prog_exists_seq, simp?)
  apply (rule parametric_prog_exists_callproc, simp?)
  apply (rule parametric_proc_exists_ref[where name="[''M'',''a'']"], (auto)[2])
  apply (rule parametric_prog_exists_callproc, simp?)
  apply (rule parametric_proc_exists_ref[where name="[''M'',''a'']"], (auto)[2])
done

lemma mt2_b_good:
  defines "E == module_type_proc_env MT2"
  defines "mk_map a == ([[''M'',''a'']\<mapsto>mk_procedure_untyped a])"
(*  shows "\<exists>p. proctype_of p = procedure_type TYPE((unit,unit)procedure) \<and> well_typed_proc' E p \<and>
    (\<forall>a::(unit,int)procedure. mk_procedure_untyped (mt2_b a) = substitute_procs_in_proc (mk_map a) p)"
  unfolding parametric_proc_exists_def[symmetric] *)
  shows "parametric_proc_exists E mk_map mt2_b"
unfolding E_def MT2_def module_type_proc_env_def MT_def procedure_type_def mk_map_def[cong] mt2_b_def[cong]
  apply (rule parametric_prog_existsI, simp)
  apply (rule parametric_prog_existsI, simp?)
  apply (rule parametric_prog_existsI, simp?)
  apply (rule parametric_proc_exists_ref[where name="[''M'',''a'']"], (auto)[2])
  apply (rule parametric_prog_existsI, simp?)
  apply (rule parametric_proc_exists_ref[where name="[''M'',''a'']"], (auto)[2])
done

definition M2 :: module where
"M2 ==
let E = (module_type_proc_env MT2) in
let mk_map = (\<lambda>a. [[''M'',''a'']\<mapsto>mk_procedure_untyped a]) in
 Abs_module \<lparr> mr_module_args=[''M''\<mapsto>MT],
              mr_procs=[[''b''] \<mapsto> parametric_proc E mk_map
                                         mt2_b ] \<rparr>"

(* MT2.a should exist an be a function "procedure \<Rightarrow> procedure" *)

lemma "has_module_type M2 MT2"
proof -
  have eq: "module_type_map_to_proc_env [''M'' \<mapsto> MT] = module_type_proc_env MT2"
    unfolding MT2_def module_type_proc_env_def by simp
  have wt_M2: "well_typed_module
     \<lparr>mr_module_args = [''M'' \<mapsto> MT],
        mr_procs =
          [[''b''] \<mapsto>
           parametric_proc (module_type_proc_env MT2)
            (\<lambda>a\<Colon>(unit, int) procedure.
                [[''M'', ''a''] \<mapsto> mk_procedure_untyped a])
            mt2_b]\<rparr>"
    unfolding well_typed_module_def
    apply auto unfolding eq
    apply (rule parametric_proc_props)
    apply (rule mt2_b_good) done
  show "has_module_type M2 MT2"
    unfolding has_module_type_def
    unfolding M2_def apply simp
    apply (subst Abs_module_inverse, simp)
    apply (rule wt_M2)
    apply (subst (2) MT2_def) apply auto
    apply (rule wt_M2)
    apply (rule parametric_proc_props)
    by (rule mt2_b_good)
qed

text {*
module M : MT = {
  proc a(x:int) { return x>0 }
  proc b(x:int, y:int) { x:=y; return () }
}
*}

locale M begin
abbreviation "x == LVariable ''x'' :: int variable"
abbreviation "y == LVariable ''y'' :: int variable"
definition M_a :: "(int*unit,bool) procedure" where
  "M_a == proc (x) { skip; return x>0 }"
definition M_b :: "(int*int*unit,unit) procedure" where
  "M_b == proc (x,y) { x:=y; return () }"
definition M :: module where
"M == Abs_module \<lparr> mr_module_args=empty,
                   mr_procs=[[''a''] \<mapsto> mk_procedure_untyped M_a,
                             [''b''] \<mapsto> mk_procedure_untyped M_b] \<rparr>"

lemma "has_module_type M MT" sorry
end

(* TODO: make sure that the args of ()procedure are well-sorted.
  Example

typedecl c
moduletype EncScheme where
    dec :: "('c*unit, unit) procedure"

should give a comprehensible error
*)

end


(* Author: Tobias Nipkow *)

section "Widening and Narrowing"

theory Abs_Int3
imports Abs_Int2_ivl
begin

class WN = SL_top +
fixes widen :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<nabla>" 65)
assumes widen1: "x \<sqsubseteq> x \<nabla> y"
assumes widen2: "y \<sqsubseteq> x \<nabla> y"
fixes narrow :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<triangle>" 65)
assumes narrow1: "y \<sqsubseteq> x \<Longrightarrow> y \<sqsubseteq> x \<triangle> y"
assumes narrow2: "y \<sqsubseteq> x \<Longrightarrow> x \<triangle> y \<sqsubseteq> x"

subsection "Intervals"

instantiation ivl :: WN
begin

definition "widen_ivl ivl1 ivl2 =
  (\<^cancel>\<open>if is_empty ivl1 then ivl2 else
   if is_empty ivl2 then ivl1 else\<close>
     case (ivl1,ivl2) of (I l1 h1, I l2 h2) \<Rightarrow>
       I (if le_option False l2 l1 \<and> l2 \<noteq> l1 then None else l1)
         (if le_option True h1 h2 \<and> h1 \<noteq> h2 then None else h1))"

definition "narrow_ivl ivl1 ivl2 =
  (\<^cancel>\<open>if is_empty ivl1 \<or> is_empty ivl2 then empty else\<close>
     case (ivl1,ivl2) of (I l1 h1, I l2 h2) \<Rightarrow>
       I (if l1 = None then l2 else l1)
         (if h1 = None then h2 else h1))"

instance
proof qed
  (auto simp add: widen_ivl_def narrow_ivl_def le_option_def le_ivl_def empty_def split: ivl.split option.split if_splits)

end

subsection "Abstract State"

instantiation st :: (WN)WN
begin

definition "widen_st F1 F2 =
  FunDom (\<lambda>x. fun F1 x \<nabla> fun F2 x) (inter_list (dom F1) (dom F2))"

definition "narrow_st F1 F2 =
  FunDom (\<lambda>x. fun F1 x \<triangle> fun F2 x) (inter_list (dom F1) (dom F2))"

instance
proof (standard, goal_cases)
  case 1 thus ?case
    by(simp add: widen_st_def le_st_def lookup_def widen1)
next
  case 2 thus ?case
    by(simp add: widen_st_def le_st_def lookup_def widen2)
next
  case 3 thus ?case
    by(auto simp: narrow_st_def le_st_def lookup_def narrow1)
next
  case 4 thus ?case
    by(auto simp: narrow_st_def le_st_def lookup_def narrow2)
qed

end

subsection "Option"

instantiation option :: (WN)WN
begin

fun widen_option where
"None \<nabla> x = x" |
"x \<nabla> None = x" |
"(Some x) \<nabla> (Some y) = Some(x \<nabla> y)"

fun narrow_option where
"None \<triangle> x = None" |
"x \<triangle> None = None" |
"(Some x) \<triangle> (Some y) = Some(x \<triangle> y)"

instance
proof (standard, goal_cases)
  case (1 x y) show ?case
    by(induct x y rule: widen_option.induct) (simp_all add: widen1)
next
  case (2 x y) show ?case
    by(induct x y rule: widen_option.induct) (simp_all add: widen2)
next
  case (3 x y) thus ?case
    by(induct x y rule: narrow_option.induct) (simp_all add: narrow1)
next
  case (4 y x) thus ?case
    by(induct x y rule: narrow_option.induct) (simp_all add: narrow2)
qed

end

subsection "Annotated commands"

fun map2_acom :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a acom \<Rightarrow> 'a acom \<Rightarrow> 'a acom" where
"map2_acom f (SKIP {a1}) (SKIP {a2}) = (SKIP {f a1 a2})" |
"map2_acom f (x ::= e {a1}) (x' ::= e' {a2}) = (x ::= e {f a1 a2})" |
"map2_acom f (c1;;c2) (c1';;c2') = (map2_acom f c1 c1';; map2_acom f c2 c2')" |
"map2_acom f (IF b THEN c1 ELSE c2 {a1}) (IF b' THEN c1' ELSE c2' {a2}) =
  (IF b THEN map2_acom f c1 c1' ELSE map2_acom f c2 c2' {f a1 a2})" |
"map2_acom f ({a1} WHILE b DO c {a2}) ({a3} WHILE b' DO c' {a4}) =
  ({f a1 a3} WHILE b DO map2_acom f c c' {f a2 a4})"

abbreviation widen_acom :: "('a::WN)acom \<Rightarrow> 'a acom \<Rightarrow> 'a acom" (infix "\<nabla>\<^sub>c" 65)
where "widen_acom == map2_acom (\<nabla>)"

abbreviation narrow_acom :: "('a::WN)acom \<Rightarrow> 'a acom \<Rightarrow> 'a acom" (infix "\<triangle>\<^sub>c" 65)
where "narrow_acom == map2_acom (\<triangle>)"

lemma widen1_acom: "strip c = strip c' \<Longrightarrow> c \<sqsubseteq> c \<nabla>\<^sub>c c'"
by(induct c c' rule: le_acom.induct)(simp_all add: widen1)

lemma widen2_acom: "strip c = strip c' \<Longrightarrow> c' \<sqsubseteq> c \<nabla>\<^sub>c c'"
by(induct c c' rule: le_acom.induct)(simp_all add: widen2)

lemma narrow1_acom: "y \<sqsubseteq> x \<Longrightarrow> y \<sqsubseteq> x \<triangle>\<^sub>c y"
by(induct y x rule: le_acom.induct) (simp_all add: narrow1)

lemma narrow2_acom: "y \<sqsubseteq> x \<Longrightarrow> x \<triangle>\<^sub>c y \<sqsubseteq> x"
by(induct y x rule: le_acom.induct) (simp_all add: narrow2)

subsection "Post-fixed point computation"

definition iter_widen :: "('a acom \<Rightarrow> 'a acom) \<Rightarrow> 'a acom \<Rightarrow> ('a::WN)acom option"
where "iter_widen f = while_option (\<lambda>c. \<not> f c \<sqsubseteq> c) (\<lambda>c. c \<nabla>\<^sub>c f c)"

definition iter_narrow :: "('a acom \<Rightarrow> 'a acom) \<Rightarrow> 'a acom \<Rightarrow> 'a::WN acom option"
where "iter_narrow f = while_option (\<lambda>c. \<not> c \<sqsubseteq> c \<triangle>\<^sub>c f c) (\<lambda>c. c \<triangle>\<^sub>c f c)"

definition pfp_wn ::
  "(('a::WN)option acom \<Rightarrow> 'a option acom) \<Rightarrow> com \<Rightarrow> 'a option acom option"
where "pfp_wn f c = (case iter_widen f (\<bottom>\<^sub>c c) of None \<Rightarrow> None
                     | Some c' \<Rightarrow> iter_narrow f c')"

lemma strip_map2_acom:
 "strip c1 = strip c2 \<Longrightarrow> strip(map2_acom f c1 c2) = strip c1"
by(induct f c1 c2 rule: map2_acom.induct) simp_all

lemma iter_widen_pfp: "iter_widen f c = Some c' \<Longrightarrow> f c' \<sqsubseteq> c'"
by(auto simp add: iter_widen_def dest: while_option_stop)

lemma strip_while: fixes f :: "'a acom \<Rightarrow> 'a acom"
assumes "\<forall>c. strip (f c) = strip c" and "while_option P f c = Some c'"
shows "strip c' = strip c"
using while_option_rule[where P = "\<lambda>c'. strip c' = strip c", OF _ assms(2)]
by (metis assms(1))

lemma strip_iter_widen: fixes f :: "'a::WN acom \<Rightarrow> 'a acom"
assumes "\<forall>c. strip (f c) = strip c" and "iter_widen f c = Some c'"
shows "strip c' = strip c"
proof-
  have "\<forall>c. strip(c \<nabla>\<^sub>c f c) = strip c" by (metis assms(1) strip_map2_acom)
  from strip_while[OF this] assms(2) show ?thesis by(simp add: iter_widen_def)
qed

lemma iter_narrow_pfp: assumes "mono f" and "f c0 \<sqsubseteq> c0"
and "iter_narrow f c0 = Some c"
shows "f c \<sqsubseteq> c \<and> c \<sqsubseteq> c0" (is "?P c")
proof-
  { fix c assume "?P c"
    note 1 = conjunct1[OF this] and 2 = conjunct2[OF this]
    let ?c' = "c \<triangle>\<^sub>c f c"
    have "?P ?c'"
    proof
      have "f ?c' \<sqsubseteq> f c"  by(rule monoD[OF \<open>mono f\<close> narrow2_acom[OF 1]])
      also have "\<dots> \<sqsubseteq> ?c'" by(rule narrow1_acom[OF 1])
      finally show "f ?c' \<sqsubseteq> ?c'" .
      have "?c' \<sqsubseteq> c" by (rule narrow2_acom[OF 1])
      also have "c \<sqsubseteq> c0" by(rule 2)
      finally show "?c' \<sqsubseteq> c0" .
    qed
  }
  with while_option_rule[where P = ?P, OF _ assms(3)[simplified iter_narrow_def]]
    assms(2) le_refl
  show ?thesis by blast
qed

lemma pfp_wn_pfp:
  "\<lbrakk> mono f;  pfp_wn f c = Some c' \<rbrakk> \<Longrightarrow> f c' \<sqsubseteq> c'"
unfolding pfp_wn_def
by (auto dest: iter_widen_pfp iter_narrow_pfp split: option.splits)

lemma strip_pfp_wn:
  "\<lbrakk> \<forall>c. strip(f c) = strip c; pfp_wn f c = Some c' \<rbrakk> \<Longrightarrow> strip c' = c"
apply(auto simp add: pfp_wn_def iter_narrow_def split: option.splits)
by (metis (mono_tags) strip_map2_acom strip_while strip_bot_acom strip_iter_widen)

locale Abs_Int2 = Abs_Int1_mono
where \<gamma>=\<gamma> for \<gamma> :: "'av::{WN,L_top_bot} \<Rightarrow> val set"
begin

definition AI_wn :: "com \<Rightarrow> 'av st option acom option" where
"AI_wn = pfp_wn (step' \<top>)"

lemma AI_wn_sound: "AI_wn c = Some c' \<Longrightarrow> CS c \<le> \<gamma>\<^sub>c c'"
proof(simp add: CS_def AI_wn_def)
  assume 1: "pfp_wn (step' \<top>) c = Some c'"
  from pfp_wn_pfp[OF mono_step'2 1]
  have 2: "step' \<top> c' \<sqsubseteq> c'" .
  have 3: "strip (\<gamma>\<^sub>c (step' \<top> c')) = c" by(simp add: strip_pfp_wn[OF _ 1])
  have "lfp (step UNIV) c \<le> \<gamma>\<^sub>c (step' \<top> c')"
  proof(rule lfp_lowerbound[simplified,OF 3])
    show "step UNIV (\<gamma>\<^sub>c (step' \<top> c')) \<le> \<gamma>\<^sub>c (step' \<top> c')"
    proof(rule step_preserves_le[OF _ _])
      show "UNIV \<subseteq> \<gamma>\<^sub>o \<top>" by simp
      show "\<gamma>\<^sub>c (step' \<top> c') \<le> \<gamma>\<^sub>c c'" by(rule mono_gamma_c[OF 2])
    qed
  qed
  from this 2 show "lfp (step UNIV) c \<le> \<gamma>\<^sub>c c'"
    by (blast intro: mono_gamma_c order_trans)
qed

end

global_interpretation Abs_Int2
where \<gamma> = \<gamma>_ivl and num' = num_ivl and plus' = plus_ivl
and test_num' = in_ivl
and filter_plus' = filter_plus_ivl and filter_less' = filter_less_ivl
defines AI_ivl' = AI_wn
..

subsection "Tests"

definition "step_up_ivl n = ((\<lambda>c. c \<nabla>\<^sub>c step_ivl \<top> c)^^n)"
definition "step_down_ivl n = ((\<lambda>c. c \<triangle>\<^sub>c step_ivl \<top> c)^^n)"

text\<open>For @{const test3_ivl}, @{const AI_ivl} needed as many iterations as
the loop took to execute. In contrast, @{const AI_ivl'} converges in a
constant number of steps:\<close>

value "show_acom (step_up_ivl 1 (\<bottom>\<^sub>c test3_ivl))"
value "show_acom (step_up_ivl 2 (\<bottom>\<^sub>c test3_ivl))"
value "show_acom (step_up_ivl 3 (\<bottom>\<^sub>c test3_ivl))"
value "show_acom (step_up_ivl 4 (\<bottom>\<^sub>c test3_ivl))"
value "show_acom (step_up_ivl 5 (\<bottom>\<^sub>c test3_ivl))"
value "show_acom (step_down_ivl 1 (step_up_ivl 5 (\<bottom>\<^sub>c test3_ivl)))"
value "show_acom (step_down_ivl 2 (step_up_ivl 5 (\<bottom>\<^sub>c test3_ivl)))"
value "show_acom (step_down_ivl 3 (step_up_ivl 5 (\<bottom>\<^sub>c test3_ivl)))"

text\<open>Now all the analyses terminate:\<close>

value "show_acom_opt (AI_ivl' test4_ivl)"
value "show_acom_opt (AI_ivl' test5_ivl)"
value "show_acom_opt (AI_ivl' test6_ivl)"

subsection "Termination: Intervals"

definition m_ivl :: "ivl \<Rightarrow> nat" where
"m_ivl ivl = (case ivl of I l h \<Rightarrow>
     (case l of None \<Rightarrow> 0 | Some _ \<Rightarrow> 1) + (case h of None \<Rightarrow> 0 | Some _ \<Rightarrow> 1))"

lemma m_ivl_height: "m_ivl ivl \<le> 2"
by(simp add: m_ivl_def split: ivl.split option.split)

lemma m_ivl_anti_mono: "(y::ivl) \<sqsubseteq> x \<Longrightarrow> m_ivl x \<le> m_ivl y"
by(auto simp: m_ivl_def le_option_def le_ivl_def
        split: ivl.split option.split if_splits)

lemma m_ivl_widen:
  "~ y \<sqsubseteq> x \<Longrightarrow> m_ivl(x \<nabla> y) < m_ivl x"
by(auto simp: m_ivl_def widen_ivl_def le_option_def le_ivl_def
        split: ivl.splits option.splits if_splits)

lemma Top_less_ivl: "\<top> \<sqsubseteq> x \<Longrightarrow> m_ivl x = 0"
by(auto simp: m_ivl_def le_option_def le_ivl_def empty_def Top_ivl_def
        split: ivl.split option.split if_splits)

definition n_ivl :: "ivl \<Rightarrow> nat" where
"n_ivl ivl = 2 - m_ivl ivl"

lemma n_ivl_mono: "(x::ivl) \<sqsubseteq> y \<Longrightarrow> n_ivl x \<le> n_ivl y"
unfolding n_ivl_def by (metis diff_le_mono2 m_ivl_anti_mono)

lemma n_ivl_narrow:
  "~ x \<sqsubseteq> x \<triangle> y \<Longrightarrow> n_ivl(x \<triangle> y) < n_ivl x"
by(auto simp: n_ivl_def m_ivl_def narrow_ivl_def le_option_def le_ivl_def
        split: ivl.splits option.splits if_splits)

subsection "Termination: Abstract State"

definition "m_st m st = (\<Sum>x\<in>set(dom st). m(fun st x))"

lemma m_st_height: assumes "finite X" and "set (dom S) \<subseteq> X"
shows "m_st m_ivl S \<le> 2 * card X"
proof(auto simp: m_st_def)
  have "(\<Sum>x\<in>set(dom S). m_ivl (fun S x)) \<le> (\<Sum>x\<in>set(dom S). 2)" (is "?L \<le> _")
    by(rule sum_mono)(simp add:m_ivl_height)
  also have "\<dots> \<le> (\<Sum>x\<in>X. 2)"
    by(rule sum_mono2[OF assms]) simp
  also have "\<dots> = 2 * card X" by(simp)
  finally show "?L \<le> \<dots>" .
qed

lemma m_st_anti_mono:
  "S1 \<sqsubseteq> S2 \<Longrightarrow> m_st m_ivl S2 \<le> m_st m_ivl S1"
proof(auto simp: m_st_def le_st_def lookup_def split: if_splits)
  let ?X = "set(dom S1)" let ?Y = "set(dom S2)"
  let ?f = "fun S1" let ?g = "fun S2"
  assume asm: "\<forall>x\<in>?Y. (x \<in> ?X \<longrightarrow> ?f x \<sqsubseteq> ?g x) \<and> (x \<in> ?X \<or> \<top> \<sqsubseteq> ?g x)"
  hence 1: "\<forall>y\<in>?Y\<inter>?X. m_ivl(?g y) \<le> m_ivl(?f y)" by(simp add: m_ivl_anti_mono)
  have 0: "\<forall>x\<in>?Y-?X. m_ivl(?g x) = 0" using asm by (auto simp: Top_less_ivl)
  have "(\<Sum>y\<in>?Y. m_ivl(?g y)) = (\<Sum>y\<in>(?Y-?X) \<union> (?Y\<inter>?X). m_ivl(?g y))"
    by (metis Un_Diff_Int)
  also have "\<dots> = (\<Sum>y\<in>?Y-?X. m_ivl(?g y)) + (\<Sum>y\<in>?Y\<inter>?X. m_ivl(?g y))"
    by(subst sum.union_disjoint) auto
  also have "(\<Sum>y\<in>?Y-?X. m_ivl(?g y)) = 0" using 0 by simp
  also have "0 + (\<Sum>y\<in>?Y\<inter>?X. m_ivl(?g y)) = (\<Sum>y\<in>?Y\<inter>?X. m_ivl(?g y))" by simp
  also have "\<dots> \<le> (\<Sum>y\<in>?Y\<inter>?X. m_ivl(?f y))"
    by(rule sum_mono)(simp add: 1)
  also have "\<dots> \<le> (\<Sum>y\<in>?X. m_ivl(?f y))"
    by(simp add: sum_mono2[of "?X" "?Y Int ?X", OF _ Int_lower2])
  finally show "(\<Sum>y\<in>?Y. m_ivl(?g y)) \<le> (\<Sum>x\<in>?X. m_ivl(?f x))" .
qed

lemma m_st_widen:
assumes "\<not> S2 \<sqsubseteq> S1" shows "m_st m_ivl (S1 \<nabla> S2) < m_st m_ivl S1"
proof-
  { let ?X = "set(dom S1)" let ?Y = "set(dom S2)"
    let ?f = "fun S1" let ?g = "fun S2"
    fix x assume "x \<in> ?X" "\<not> lookup S2 x \<sqsubseteq> ?f x"
    have "(\<Sum>x\<in>?X\<inter>?Y. m_ivl(?f x \<nabla> ?g x)) < (\<Sum>x\<in>?X. m_ivl(?f x))" (is "?L < ?R")
    proof cases
      assume "x : ?Y"
      have "?L < (\<Sum>x\<in>?X\<inter>?Y. m_ivl(?f x))"
      proof(rule sum_strict_mono_ex1, simp)
        show "\<forall>x\<in>?X\<inter>?Y. m_ivl(?f x \<nabla> ?g x) \<le> m_ivl (?f x)"
          by (metis m_ivl_anti_mono widen1)
      next
        show "\<exists>x\<in>?X\<inter>?Y. m_ivl(?f x \<nabla> ?g x) < m_ivl(?f x)"
          using \<open>x:?X\<close> \<open>x:?Y\<close> \<open>\<not> lookup S2 x \<sqsubseteq> ?f x\<close>
          by (metis IntI m_ivl_widen lookup_def)
      qed
      also have "\<dots> \<le> ?R" by(simp add: sum_mono2[OF _ Int_lower1])
      finally show ?thesis .
    next
      assume "x ~: ?Y"
      have "?L \<le> (\<Sum>x\<in>?X\<inter>?Y. m_ivl(?f x))"
      proof(rule sum_mono, simp)
        fix x assume "x:?X \<and> x:?Y" show "m_ivl(?f x \<nabla> ?g x) \<le> m_ivl (?f x)"
          by (metis m_ivl_anti_mono widen1)
      qed
      also have "\<dots> < m_ivl(?f x) + \<dots>"
        using m_ivl_widen[OF \<open>\<not> lookup S2 x \<sqsubseteq> ?f x\<close>]
        by (metis Nat.le_refl add_strict_increasing gr0I not_less0)
      also have "\<dots> = (\<Sum>y\<in>insert x (?X\<inter>?Y). m_ivl(?f y))"
        using \<open>x ~: ?Y\<close> by simp
      also have "\<dots> \<le> (\<Sum>x\<in>?X. m_ivl(?f x))"
        by(rule sum_mono2)(insert \<open>x:?X\<close>, auto)
      finally show ?thesis .
    qed
  } with assms show ?thesis
    by(auto simp: le_st_def widen_st_def m_st_def Int_def)
qed

definition "n_st m X st = (\<Sum>x\<in>X. m(lookup st x))"

lemma n_st_mono: assumes "set(dom S1) \<subseteq> X" "set(dom S2) \<subseteq> X" "S1 \<sqsubseteq> S2"
shows "n_st n_ivl X S1 \<le> n_st n_ivl X S2"
proof-
  have "(\<Sum>x\<in>X. n_ivl(lookup S1 x)) \<le> (\<Sum>x\<in>X. n_ivl(lookup S2 x))"
    apply(rule sum_mono) using assms
    by(auto simp: le_st_def lookup_def n_ivl_mono split: if_splits)
  thus ?thesis by(simp add: n_st_def)
qed

lemma n_st_narrow:
assumes "finite X" and "set(dom S1) \<subseteq> X" "set(dom S2) \<subseteq> X"
and "S2 \<sqsubseteq> S1" "\<not> S1 \<sqsubseteq> S1 \<triangle> S2"
shows "n_st n_ivl X (S1 \<triangle> S2) < n_st n_ivl X S1"
proof-
  have 1: "\<forall>x\<in>X. n_ivl (lookup (S1 \<triangle> S2) x) \<le> n_ivl (lookup S1 x)"
    using assms(2-4)
    by(auto simp: le_st_def narrow_st_def lookup_def n_ivl_mono narrow2
            split: if_splits)
  have 2: "\<exists>x\<in>X. n_ivl (lookup (S1 \<triangle> S2) x) < n_ivl (lookup S1 x)"
    using assms(2-5)
    by(auto simp: le_st_def narrow_st_def lookup_def intro: n_ivl_narrow
            split: if_splits)
  have "(\<Sum>x\<in>X. n_ivl(lookup (S1 \<triangle> S2) x)) < (\<Sum>x\<in>X. n_ivl(lookup S1 x))"
    apply(rule sum_strict_mono_ex1[OF \<open>finite X\<close>]) using 1 2 by blast+
  thus ?thesis by(simp add: n_st_def)
qed

subsection "Termination: Option"

definition "m_o m n opt = (case opt of None \<Rightarrow> n+1 | Some x \<Rightarrow> m x)"

lemma m_o_anti_mono: "finite X \<Longrightarrow> domo S2 \<subseteq> X \<Longrightarrow> S1 \<sqsubseteq> S2 \<Longrightarrow>
  m_o (m_st m_ivl) (2 * card X) S2 \<le> m_o (m_st m_ivl) (2 * card X) S1"
apply(induction S1 S2 rule: le_option.induct)
apply(auto simp: domo_def m_o_def m_st_anti_mono le_SucI m_st_height
           split: option.splits)
done

lemma m_o_widen: "\<lbrakk> finite X; domo S2 \<subseteq> X; \<not> S2 \<sqsubseteq> S1 \<rbrakk> \<Longrightarrow>
  m_o (m_st m_ivl) (2 * card X) (S1 \<nabla> S2) < m_o (m_st m_ivl) (2 * card X) S1"
by(auto simp: m_o_def domo_def m_st_height less_Suc_eq_le m_st_widen
        split: option.split)

definition "n_o n opt = (case opt of None \<Rightarrow> 0 | Some x \<Rightarrow> n x + 1)"

lemma n_o_mono: "domo S1 \<subseteq> X \<Longrightarrow> domo S2 \<subseteq> X \<Longrightarrow> S1 \<sqsubseteq> S2 \<Longrightarrow>
  n_o (n_st n_ivl X) S1 \<le> n_o (n_st n_ivl X) S2"
apply(induction S1 S2 rule: le_option.induct)
apply(auto simp: domo_def n_o_def n_st_mono
           split: option.splits)
done

lemma n_o_narrow:
  "\<lbrakk> finite X; domo S1 \<subseteq> X; domo S2 \<subseteq> X; S2 \<sqsubseteq> S1; \<not> S1 \<sqsubseteq> S1 \<triangle> S2 \<rbrakk>
  \<Longrightarrow> n_o (n_st n_ivl X) (S1 \<triangle> S2) < n_o (n_st n_ivl X) S1"
apply(induction S1 S2 rule: narrow_option.induct)
apply(auto simp: n_o_def domo_def n_st_narrow)
done

lemma domo_widen_subset: "domo (S1 \<nabla> S2) \<subseteq> domo S1 \<union> domo S2"
apply(induction S1 S2 rule: widen_option.induct)
apply (auto simp: domo_def widen_st_def)
done

lemma domo_narrow_subset: "domo (S1 \<triangle> S2) \<subseteq> domo S1 \<union> domo S2"
apply(induction S1 S2 rule: narrow_option.induct)
apply (auto simp: domo_def narrow_st_def)
done

subsection "Termination: Commands"

lemma strip_widen_acom[simp]:
  "strip c' = strip (c::'a::WN acom) \<Longrightarrow>  strip (c \<nabla>\<^sub>c c') = strip c"
by(induction "widen::'a\<Rightarrow>'a\<Rightarrow>'a" c c' rule: map2_acom.induct) simp_all

lemma strip_narrow_acom[simp]:
  "strip c' = strip (c::'a::WN acom) \<Longrightarrow>  strip (c \<triangle>\<^sub>c c') = strip c"
by(induction "narrow::'a\<Rightarrow>'a\<Rightarrow>'a" c c' rule: map2_acom.induct) simp_all

lemma annos_widen_acom[simp]: "strip c1 = strip (c2::'a::WN acom) \<Longrightarrow>
  annos(c1 \<nabla>\<^sub>c c2) = map (%(x,y).x\<nabla>y) (zip (annos c1) (annos(c2::'a::WN acom)))"
by(induction "widen::'a\<Rightarrow>'a\<Rightarrow>'a" c1 c2 rule: map2_acom.induct)
  (simp_all add: size_annos_same2)

lemma annos_narrow_acom[simp]: "strip c1 = strip (c2::'a::WN acom) \<Longrightarrow>
  annos(c1 \<triangle>\<^sub>c c2) = map (%(x,y).x\<triangle>y) (zip (annos c1) (annos(c2::'a::WN acom)))"
by(induction "narrow::'a\<Rightarrow>'a\<Rightarrow>'a" c1 c2 rule: map2_acom.induct)
  (simp_all add: size_annos_same2)

lemma widen_acom_Com[simp]: "strip c2 = strip c1 \<Longrightarrow>
  c1 : Com X \<Longrightarrow> c2 : Com X \<Longrightarrow> (c1 \<nabla>\<^sub>c c2) : Com X"
apply(auto simp add: Com_def)
apply(rename_tac S S' x)
apply(erule in_set_zipE)
apply(auto simp: domo_def split: option.splits)
apply(case_tac S)
apply(case_tac S')
apply simp
apply fastforce
apply(case_tac S')
apply fastforce
apply (fastforce simp: widen_st_def)
done

lemma narrow_acom_Com[simp]: "strip c2 = strip c1 \<Longrightarrow>
  c1 : Com X \<Longrightarrow> c2 : Com X \<Longrightarrow> (c1 \<triangle>\<^sub>c c2) : Com X"
apply(auto simp add: Com_def)
apply(rename_tac S S' x)
apply(erule in_set_zipE)
apply(auto simp: domo_def split: option.splits)
apply(case_tac S)
apply(case_tac S')
apply simp
apply fastforce
apply(case_tac S')
apply fastforce
apply (fastforce simp: narrow_st_def)
done

definition "m_c m c = (let as = annos c in \<Sum>i=0..<size as. m(as!i))"

lemma measure_m_c: "finite X \<Longrightarrow> {(c, c \<nabla>\<^sub>c c') |c c'::ivl st option acom.
     strip c' = strip c \<and> c : Com X \<and> c' : Com X \<and> \<not> c' \<sqsubseteq> c}\<inverse>
    \<subseteq> measure(m_c(m_o (m_st m_ivl) (2*card(X))))"
apply(auto simp: m_c_def Let_def Com_def)
apply(subgoal_tac "length(annos c') = length(annos c)")
prefer 2 apply (simp add: size_annos_same2)
apply (auto)
apply(rule sum_strict_mono_ex1)
apply simp
apply (clarsimp)
apply(erule m_o_anti_mono)
apply(rule subset_trans[OF domo_widen_subset])
apply fastforce
apply(rule widen1)
apply(auto simp: le_iff_le_annos listrel_iff_nth)
apply(rule_tac x=n in bexI)
prefer 2 apply simp
apply(erule m_o_widen)
apply (simp)+
done

lemma measure_n_c: "finite X \<Longrightarrow> {(c, c \<triangle>\<^sub>c c') |c c'.
  strip c = strip c' \<and> c \<in> Com X \<and> c' \<in> Com X \<and> c' \<sqsubseteq> c \<and> \<not> c \<sqsubseteq> c \<triangle>\<^sub>c c'}\<inverse>
  \<subseteq> measure(m_c(n_o (n_st n_ivl X)))"
apply(auto simp: m_c_def Let_def Com_def)
apply(subgoal_tac "length(annos c') = length(annos c)")
prefer 2 apply (simp add: size_annos_same2)
apply (auto)
apply(rule sum_strict_mono_ex1)
apply simp
apply (clarsimp)
apply(rule n_o_mono)
using domo_narrow_subset apply fastforce
apply fastforce
apply(rule narrow2)
apply(fastforce simp: le_iff_le_annos listrel_iff_nth)
apply(auto simp: le_iff_le_annos listrel_iff_nth)
apply(rule_tac x=n in bexI)
prefer 2 apply simp
apply(erule n_o_narrow)
apply (simp)+
done

subsection "Termination: Post-Fixed Point Iterations"

lemma iter_widen_termination:
fixes c0 :: "'a::WN acom"
assumes P_f: "\<And>c. P c \<Longrightarrow> P(f c)"
assumes P_widen: "\<And>c c'. P c \<Longrightarrow> P c' \<Longrightarrow> P(c \<nabla>\<^sub>c c')"
and "wf({(c::'a acom,c \<nabla>\<^sub>c c')|c c'. P c \<and> P c' \<and> ~ c' \<sqsubseteq> c}^-1)"
and "P c0" and "c0 \<sqsubseteq> f c0" shows "\<exists>c. iter_widen f c0 = Some c"
proof(simp add: iter_widen_def, rule wf_while_option_Some[where P = "P"])
  show "wf {(cc', c). (P c \<and> \<not> f c \<sqsubseteq> c) \<and> cc' = c \<nabla>\<^sub>c f c}"
    apply(rule wf_subset[OF assms(3)]) by(blast intro: P_f)
next
  show "P c0" by(rule \<open>P c0\<close>)
next
  fix c assume "P c" thus "P (c \<nabla>\<^sub>c f c)" by(simp add: P_f P_widen)
qed

lemma iter_narrow_termination:
assumes P_f: "\<And>c. P c \<Longrightarrow> P(c \<triangle>\<^sub>c f c)"
and wf: "wf({(c, c \<triangle>\<^sub>c f c)|c c'. P c \<and> ~ c \<sqsubseteq> c \<triangle>\<^sub>c f c}^-1)"
and "P c0" shows "\<exists>c. iter_narrow f c0 = Some c"
proof(simp add: iter_narrow_def, rule wf_while_option_Some[where P = "P"])
  show "wf {(c', c). (P c \<and> \<not> c \<sqsubseteq> c \<triangle>\<^sub>c f c) \<and> c' = c \<triangle>\<^sub>c f c}"
    apply(rule wf_subset[OF wf]) by(blast intro: P_f)
next
  show "P c0" by(rule \<open>P c0\<close>)
next
  fix c assume "P c" thus "P (c \<triangle>\<^sub>c f c)" by(simp add: P_f)
qed

lemma iter_winden_step_ivl_termination:
  "\<exists>c. iter_widen (step_ivl \<top>) (\<bottom>\<^sub>c c0) = Some c"
apply(rule iter_widen_termination[where
  P = "%c. strip c = c0 \<and> c : Com(vars c0)"])
apply (simp_all add: step'_Com bot_acom)
apply(rule wf_subset)
apply(rule wf_measure)
apply(rule subset_trans)
prefer 2
apply(rule measure_m_c[where X = "vars c0", OF finite_cvars])
apply blast
done

lemma iter_narrow_step_ivl_termination:
  "c0 \<in> Com (vars(strip c0)) \<Longrightarrow> step_ivl \<top> c0 \<sqsubseteq> c0 \<Longrightarrow>
  \<exists>c. iter_narrow (step_ivl \<top>) c0 = Some c"
apply(rule iter_narrow_termination[where
  P = "%c. strip c = strip c0 \<and> c : Com(vars(strip c0)) \<and> step_ivl \<top> c \<sqsubseteq> c"])
apply (simp_all add: step'_Com)
apply(clarify)
apply(frule narrow2_acom, drule mono_step'[OF le_refl], erule le_trans[OF _ narrow1_acom])
apply assumption
apply(rule wf_subset)
apply(rule wf_measure)
apply(rule subset_trans)
prefer 2
apply(rule measure_n_c[where X = "vars(strip c0)", OF finite_cvars])
apply auto
by (metis bot_least domo_Top order_refl step'_Com strip_step')

(* FIXME: simplify type system: Combine Com(X) and vars <= X?? *)
lemma while_Com:
fixes c :: "'a st option acom"
assumes "while_option P f c = Some c'"
and "!!c. strip(f c) = strip c"
and "\<forall>c::'a st option acom. c : Com(X) \<longrightarrow> vars(strip c) \<subseteq> X \<longrightarrow> f c : Com(X)"
and "c : Com(X)" and "vars(strip c) \<subseteq> X" shows "c' : Com(X)"
using while_option_rule[where P = "\<lambda>c'. c' : Com(X) \<and> vars(strip c') \<subseteq> X", OF _ assms(1)]
by(simp add: assms(2-))

lemma iter_widen_Com: fixes f :: "'a::WN st option acom \<Rightarrow> 'a st option acom"
assumes "iter_widen f c = Some c'"
and "\<forall>c. c : Com(X) \<longrightarrow> vars(strip c) \<subseteq> X \<longrightarrow> f c : Com(X)"
and "!!c. strip(f c) = strip c"
and "c : Com(X)" and "vars (strip c) \<subseteq> X" shows "c' : Com(X)"
proof-
  have "\<forall>c. c : Com(X) \<longrightarrow> vars(strip c) \<subseteq> X \<longrightarrow> c \<nabla>\<^sub>c f c : Com(X)"
    by (metis (full_types) widen_acom_Com assms(2,3))
  from while_Com[OF assms(1)[simplified iter_widen_def] _ this assms(4,5)]
  show ?thesis using assms(3) by(simp)
qed

context Abs_Int2
begin

lemma iter_widen_step'_Com:
  "iter_widen (step' \<top>) c = Some c' \<Longrightarrow> vars(strip c) \<subseteq> X \<Longrightarrow> c : Com(X)
   \<Longrightarrow> c' : Com(X)"
apply(subgoal_tac "strip c'= strip c")
prefer 2 apply (metis strip_iter_widen strip_step')
apply(drule iter_widen_Com)
prefer 3 apply assumption
prefer 3 apply assumption
apply (auto simp: step'_Com)
done

end

theorem AI_ivl'_termination:
  "\<exists>c'. AI_ivl' c = Some c'"
apply(auto simp: AI_wn_def pfp_wn_def iter_winden_step_ivl_termination split: option.split)
apply(rule iter_narrow_step_ivl_termination)
apply (metis bot_acom_Com iter_widen_step'_Com[OF _ subset_refl] strip_iter_widen strip_step')
apply(erule iter_widen_pfp)
done

end

(* interesting(?) relic
lemma widen_assoc:
  "~ (y::ivl) \<sqsubseteq> x \<Longrightarrow> ~ z \<sqsubseteq> x \<nabla> y \<Longrightarrow> ((x::ivl) \<nabla> y) \<nabla> z = x \<nabla> (y \<nabla> z)"
apply(cases x)
apply(cases y)
apply(cases z)
apply(rename_tac x1 x2 y1 y2 z1 z2)
apply(simp add: le_ivl_def)
apply(case_tac x1)
apply(case_tac x2)
apply(simp add:le_option_def widen_ivl_def split: if_splits option.splits)
apply(simp add:le_option_def widen_ivl_def split: if_splits option.splits)
apply(case_tac x2)
apply(simp add:le_option_def widen_ivl_def split: if_splits option.splits)
apply(case_tac y1)
apply(case_tac y2)
apply(simp add:le_option_def widen_ivl_def split: if_splits option.splits)
apply(case_tac z1)
apply(auto simp add:le_option_def widen_ivl_def split: if_splits option.splits ivl.splits)[1]
apply(auto simp add:le_option_def widen_ivl_def split: if_splits option.splits ivl.splits)[1]
apply(case_tac y2)
apply(auto simp add:le_option_def widen_ivl_def split: if_splits option.splits ivl.splits)[1]
apply(case_tac z1)
apply(auto simp add:le_option_def widen_ivl_def split: if_splits ivl.splits option.splits)[1]
apply(case_tac z2)
apply(auto simp add:le_option_def widen_ivl_def split: if_splits option.splits)[1]
apply(auto simp add:le_option_def widen_ivl_def split: if_splits option.splits)[1]
done

lemma widen_step_trans:
  "~ (y::ivl) \<sqsubseteq> x \<Longrightarrow> ~ z \<sqsubseteq> x \<nabla> y \<Longrightarrow> \<exists>u. (x \<nabla> y) \<nabla> z = x \<nabla> u \<and> ~ u \<sqsubseteq> x"
by (metis widen_assoc preord_class.le_trans widen1)
*)


section \<open>Finite Prefixes of Infinite Sequences\<close>

theory Word_Prefixes
imports
  List_Prefixes
  "../Extensions/List_Extensions"
  Transition_Systems_and_Automata.Sequence
begin

  definition prefix_fininf :: "'a list \<Rightarrow> 'a stream \<Rightarrow> bool" (infix "\<le>\<^sub>F\<^sub>I" 50)
    where "u \<le>\<^sub>F\<^sub>I v \<equiv> \<exists> w. u @- w = v"

  lemma prefix_fininfI[intro]:
    assumes "u @- w = v"
    shows "u \<le>\<^sub>F\<^sub>I v"
    using assms unfolding prefix_fininf_def by auto
  lemma prefix_fininfE[elim]:
    assumes "u \<le>\<^sub>F\<^sub>I v"
    obtains w
    where "v = u @- w"
    using assms unfolding prefix_fininf_def by auto

  lemma prefix_fininfI_empty[intro!]: "[] \<le>\<^sub>F\<^sub>I w" by force
  lemma prefix_fininfI_item[intro!]:
    assumes "a = b" "u \<le>\<^sub>F\<^sub>I v"
    shows "a # u \<le>\<^sub>F\<^sub>I b ## v"
    using assms by force
  lemma prefix_fininfE_item[elim!]:
    assumes "a # u \<le>\<^sub>F\<^sub>I b ## v"
    obtains "a = b" "u \<le>\<^sub>F\<^sub>I v"
    using assms by force

  lemma prefix_fininf_item[simp]: "a # u \<le>\<^sub>F\<^sub>I a ## v \<longleftrightarrow> u \<le>\<^sub>F\<^sub>I v" by force
  lemma prefix_fininf_list[simp]: "w @ u \<le>\<^sub>F\<^sub>I w @- v \<longleftrightarrow> u \<le>\<^sub>F\<^sub>I v" by (induct w, auto)
  lemma prefix_fininf_conc[intro]: "u \<le>\<^sub>F\<^sub>I u @- v" by auto
  lemma prefix_fininf_prefix[intro]: "stake k w \<le>\<^sub>F\<^sub>I w" using stake_sdrop by blast
  lemma prefix_fininf_set_range[dest]: "u \<le>\<^sub>F\<^sub>I v \<Longrightarrow> set u \<subseteq> sset v" by auto

  lemma prefix_fininf_absorb:
    assumes "u \<le>\<^sub>F\<^sub>I v @- w" "length u \<le> length v"
    shows "u \<le> v"
  proof -
    obtain x where 1: "u @- x = v @- w" using assms(1) by auto
    have "u \<le> u @ stake (length v - length u) x" by rule
    also have "\<dots> = stake (length v) (u @- x)" using assms(2) by (simp add: stake_shift)
    also have "\<dots> = stake (length v) (v @- w)" unfolding 1 by rule
    also have "\<dots> = v" using eq_shift by blast
    finally show ?thesis by this
  qed
  lemma prefix_fininf_extend:
    assumes "u \<le>\<^sub>F\<^sub>I v @- w" "length v \<le> length u"
    shows "v \<le> u"
  proof -
    obtain x where 1: "u @- x = v @- w" using assms(1) by auto
    have "v \<le> v @ stake (length u - length v) w" by rule
    also have "\<dots> = stake (length u) (v @- w)" using assms(2) by (simp add: stake_shift)
    also have "\<dots> = stake (length u) (u @- x)" unfolding 1 by rule
    also have "\<dots> = u" using eq_shift by blast
    finally show ?thesis by this
  qed
  lemma prefix_fininf_length:
    assumes "u \<le>\<^sub>F\<^sub>I w" "v \<le>\<^sub>F\<^sub>I w" "length u \<le> length v"
    shows "u \<le> v"
  proof -
    obtain u' v' where 1: "w = u @- u'" "w = v @- v'" using assms(1, 2) by blast+
    have "u = stake (length u) (u @- u')" using shift_eq by blast
    also have "\<dots> = stake (length u) w" unfolding 1(1) by rule
    also have "\<dots> = stake (length u) (v @- v')" unfolding 1(2) by rule
    also have "\<dots> = take (length u) v" using assms by (simp add: min.absorb2 stake_append)
    also have "\<dots> \<le> v" by rule
    finally show ?thesis by this
  qed

  lemma prefix_fininf_append:
    assumes "u \<le>\<^sub>F\<^sub>I v @- w"
    obtains (absorb) "u \<le> v" | (extend) z where "u = v @ z" "z \<le>\<^sub>F\<^sub>I w"
  proof (cases "length u" "length v" rule: le_cases)
    case le
    obtain x where 1: "u @- x = v @- w" using assms(1) by auto
    show ?thesis
    proof (rule absorb)
      have "u \<le> u @ stake (length v - length u) x" by rule
      also have "\<dots> = stake (length v) (u @- x)" using le by (simp add: stake_shift)
      also have "\<dots> = stake (length v) (v @- w)" unfolding 1 by rule
      also have "\<dots> = v" using eq_shift by blast
      finally show "u \<le> v" by this
    qed
  next
    case ge
    obtain x where 1: "u @- x = v @- w" using assms(1) by auto
    show ?thesis
    proof (rule extend)
      have "u = stake (length u) (u @- x)" using shift_eq by auto
      also have "\<dots> = stake (length u) (v @- w)" unfolding 1 by rule
      also have "\<dots> = v @ stake (length u - length v) w" using ge by (simp add: stake_shift)
      finally show "u = v @ stake (length u - length v) w" by this
      show "stake (length u - length v) w \<le>\<^sub>F\<^sub>I w" by rule
    qed
  qed

  lemma prefix_fin_prefix_fininf_trans[trans, intro]: "u \<le> v \<Longrightarrow> v \<le>\<^sub>F\<^sub>I w \<Longrightarrow> u \<le>\<^sub>F\<^sub>I w"
    by (metis Prefix_Order.prefixE prefix_fininf_def shift_append)

  lemma prefix_finE_nth:
    assumes "u \<le> v" "i < length u"
    shows "u ! i = v ! i"
  proof -
    obtain w where 1: "v = u @ w" using assms(1) by auto
    show ?thesis unfolding 1 using assms(2) by (simp add: nth_append)
  qed
  lemma prefix_fininfI_nth:
    assumes "\<And> i. i < length u \<Longrightarrow> u ! i = w !! i"
    shows "u \<le>\<^sub>F\<^sub>I w"
  proof (rule prefix_fininfI)
    show "u @- sdrop (length u) w = w" by (simp add: assms list_eq_iff_nth_eq shift_eq)
  qed

  definition chain :: "(nat \<Rightarrow> 'a list) \<Rightarrow> bool"
    where "chain w \<equiv> mono w \<and> (\<forall> k. \<exists> l. k < length (w l))"
  definition limit :: "(nat \<Rightarrow> 'a list) \<Rightarrow> 'a stream"
    where "limit w \<equiv> smap (\<lambda> k. w (SOME l. k < length (w l)) ! k) nats"

  lemma chainI[intro?]:
    assumes "mono w"
    assumes "\<And> k. \<exists> l. k < length (w l)"
    shows "chain w"
    using assms unfolding chain_def by auto
  lemma chainD_mono[dest?]:
    assumes "chain w"
    shows "mono w"
    using assms unfolding chain_def by auto
  lemma chainE_length[elim?]:
    assumes "chain w"
    obtains l
    where "k < length (w l)"
    using assms unfolding chain_def by auto

  lemma chain_prefix_limit:
    assumes "chain w"
    shows "w k \<le>\<^sub>F\<^sub>I limit w"
  proof (rule prefix_fininfI_nth)
    fix i
    assume 1: "i < length (w k)"
    have 2: "mono w" "\<And> k. \<exists> l. k < length (w l)" using chainD_mono chainE_length assms by blast+
    have 3: "i < length (w (SOME l. i < length (w l)))" using someI_ex 2(2) by this
    show "w k ! i = limit w !! i"
    proof (cases "k" "SOME l. i < length (w l)" rule: le_cases)
      case (le)
      have 4: "w k \<le> w (SOME l. i < length (w l))" using monoD 2(1) le by this
      show ?thesis unfolding limit_def using prefix_finE_nth 4 1 by auto
    next
      case (ge)
      have 4: "w (SOME l. i < length (w l)) \<le> w k" using monoD 2(1) ge by this
      show ?thesis unfolding limit_def using prefix_finE_nth 4 3 by auto
    qed
  qed

  lemma chain_construct_1:
    assumes "P 0 x\<^sub>0" "\<And> k x. P k x \<Longrightarrow> \<exists> x'. P (Suc k) x' \<and> f x \<le> f x'"
    assumes "\<And> k x. P k x \<Longrightarrow> k \<le> length (f x)"
    obtains Q
    where "\<And> k. P k (Q k)" "chain (f \<circ> Q)"
  proof -
    obtain x' where 1:
      "P 0 x\<^sub>0" "\<And> k x. P k x \<Longrightarrow> P (Suc k) (x' k x) \<and> f x \<le> f (x' k x)"
      using assms(1, 2) by metis
    define Q where "Q \<equiv> rec_nat x\<^sub>0 x'"
    have [simp]: "Q 0 = x\<^sub>0" "\<And> k. Q (Suc k) = x' k (Q k)" unfolding Q_def by simp+
    have 2: "\<And> k. P k (Q k)"
    proof -
      fix k
      show "P k (Q k)" using 1 by (induct k, auto)
    qed
    show ?thesis
    proof (intro that chainI monoI, unfold comp_apply)
      fix k
      show "P k (Q k)" using 2 by this
    next
      fix x y :: nat
      assume "x \<le> y"
      thus "f (Q x) \<le> f (Q y)"
      proof (induct "y - x" arbitrary: x y)
        case 0
        show ?case using 0 by simp
      next
        case (Suc k)
        have "f (Q x) \<le> f (Q (Suc x))" using 1(2) 2 by auto
        also have "\<dots> \<le> f (Q y)" using Suc(2) by (intro Suc(1), auto)
        finally show ?case by this
      qed
    next
      fix k
      have 3: "P (Suc k) (Q (Suc k))" using 2 by this
      have 4: "Suc k \<le> length (f (Q (Suc k)))" using assms(3) 3 by this
      have 5: "k < length (f (Q (Suc k)))" using 4 by auto
      show "\<exists> l. k < length (f (Q l))" using 5 by blast
    qed
  qed
  lemma chain_construct_2:
    assumes "P 0 x\<^sub>0" "\<And> k x. P k x \<Longrightarrow> \<exists> x'. P (Suc k) x' \<and> f x \<le> f x' \<and> g x \<le> g x'"
    assumes "\<And> k x. P k x \<Longrightarrow> k \<le> length (f x)" "\<And> k x. P k x \<Longrightarrow> k \<le> length (g x)"
    obtains Q
    where "\<And> k. P k (Q k)" "chain (f \<circ> Q)" "chain (g \<circ> Q)"
  proof -
    obtain x' where 1:
      "P 0 x\<^sub>0" "\<And> k x. P k x \<Longrightarrow> P (Suc k) (x' k x) \<and> f x \<le> f (x' k x) \<and> g x \<le> g (x' k x)"
      using assms(1, 2) by metis
    define Q where "Q \<equiv> rec_nat x\<^sub>0 x'"
    have [simp]: "Q 0 = x\<^sub>0" "\<And> k. Q (Suc k) = x' k (Q k)" unfolding Q_def by simp+
    have 2: "\<And> k. P k (Q k)"
    proof -
      fix k
      show "P k (Q k)" using 1 by (induct k, auto)
    qed
    show ?thesis
    proof (intro that chainI monoI, unfold comp_apply)
      fix k
      show "P k (Q k)" using 2 by this
    next
      fix x y :: nat
      assume "x \<le> y"
      thus "f (Q x) \<le> f (Q y)"
      proof (induct "y - x" arbitrary: x y)
        case 0
        show ?case using 0 by simp
      next
        case (Suc k)
        have "f (Q x) \<le> f (Q (Suc x))" using 1(2) 2 by auto
        also have "\<dots> \<le> f (Q y)" using Suc(2) by (intro Suc(1), auto)
        finally show ?case by this
      qed
    next
      fix k
      have 3: "P (Suc k) (Q (Suc k))" using 2 by this
      have 4: "Suc k \<le> length (f (Q (Suc k)))" using assms(3) 3 by this
      have 5: "k < length (f (Q (Suc k)))" using 4 by auto
      show "\<exists> l. k < length (f (Q l))" using 5 by blast
    next
      fix x y :: nat
      assume "x \<le> y"
      thus "g (Q x) \<le> g (Q y)"
      proof (induct "y - x" arbitrary: x y)
        case 0
        show ?case using 0 by simp
      next
        case (Suc k)
        have "g (Q x) \<le> g (Q (Suc x))" using 1(2) 2 by auto
        also have "\<dots> \<le> g (Q y)" using Suc(2) by (intro Suc(1), auto)
        finally show ?case by this
      qed
    next
      fix k
      have 3: "P (Suc k) (Q (Suc k))" using 2 by this
      have 4: "Suc k \<le> length (g (Q (Suc k)))" using assms(4) 3 by this
      have 5: "k < length (g (Q (Suc k)))" using 4 by auto
      show "\<exists> l. k < length (g (Q l))" using 5 by blast
    qed
  qed
  lemma chain_construct_2':
    assumes "P 0 u\<^sub>0 v\<^sub>0" "\<And> k u v. P k u v \<Longrightarrow> \<exists> u' v'. P (Suc k) u' v' \<and> u \<le> u' \<and> v \<le> v'"
    assumes "\<And> k u v. P k u v \<Longrightarrow> k \<le> length u" "\<And> k u v. P k u v \<Longrightarrow> k \<le> length v"
    obtains u v
    where "\<And> k. P k (u k) (v k)" "chain u" "chain v"
  proof -
    obtain Q where 1: "\<And> k. (case_prod \<circ> P) k (Q k)" "chain (fst \<circ> Q)" "chain (snd \<circ> Q)"
    proof (rule chain_construct_2)
      show "\<exists> x'. (case_prod \<circ> P) (Suc k) x' \<and> fst x \<le> fst x' \<and> snd x \<le> snd x'"
        if "(case_prod \<circ> P) k x" for k x using assms that by auto
      show "(case_prod \<circ> P) 0 (u\<^sub>0, v\<^sub>0)" using assms by auto
      show "k \<le> length (fst x)" if "(case_prod \<circ> P) k x" for k x using assms that by auto
      show "k \<le> length (snd x)" if "(case_prod \<circ> P) k x" for k x using assms that by auto
    qed rule
    show ?thesis
    proof
      show "P k ((fst \<circ> Q) k) ((snd \<circ> Q) k)" for k using 1(1) by (auto simp: prod.case_eq_if)
      show "chain (fst \<circ> Q)" "chain (snd \<circ> Q)" using 1(2, 3) by this
    qed
  qed

end


theory tut6
imports Main
begin

datatype 'a TREE = LEAF 'a | NODE 'a "'a TREE" "'a TREE"

primrec MIRROR :: "'a TREE \<Rightarrow> 'a TREE" where
"MIRROR (LEAF x) = LEAF x" |
"MIRROR (NODE x left right) = NODE x (MIRROR right) (MIRROR left)"

thm TREE.induct

lemma "MIRROR(MIRROR t) = t"
proof (induction t)
  case LEAF
  then show ?case by simp
next
  case (NODE x left right)
  then show ?case by simp
qed

end


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

Some small examples for programs that may abort.
*)

theory ExamplesAbort imports Hoare_Logic_Abort begin

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

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

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

end


(* Title:      Domain Iterings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Domain Iterings\<close>

theory Domain_Iterings

imports Domain Lattice_Ordered_Semirings Omega_Algebras

begin

class domain_semiring_lattice = left_zero_domain_semiring + lattice_ordered_pre_left_semiring
begin

subclass bounded_idempotent_left_zero_semiring ..

lemma d_top:
  "d(top) = 1"
  by (metis sup_left_top d_dist_sup d_one d_plus_one)

lemma mult_domain_top:
  "x * d(y) * top \<le> d(x * y) * top"
  by (smt d_mult_d d_restrict_equals mult_assoc mult_right_isotone top_greatest)

lemma domain_meet_domain:
  "d(x \<sqinter> d(y) * z) \<le> d(y)"
  by (metis d_export d_isotone d_mult_greatest_lower_bound inf.cobounded2)

lemma meet_domain:
  "x \<sqinter> d(y) * z = d(y) * (x \<sqinter> z)"
  apply (rule order.antisym)
  apply (metis domain_meet_domain d_mult_below d_restrict_equals inf_mono mult_isotone)
  by (meson d_mult_below le_inf_iff mult_left_sub_dist_inf_right)

lemma meet_intro_domain:
  "x \<sqinter> y = d(y) * x \<sqinter> y"
  by (metis d_restrict_equals inf_commute meet_domain)

lemma meet_domain_top:
  "x \<sqinter> d(y) * top = d(y) * x"
  by (simp add: meet_domain)

proposition "d(x) = x * top \<sqinter> 1" nitpick [expect=genuine,card=3] oops

lemma d_galois:
  "d(x) \<le> d(y) \<longleftrightarrow> x \<le> d(y) * top"
  by (metis d_export d_isotone d_mult_left_absorb_sup d_plus_one d_restrict_equals d_top mult_isotone top.extremum)

lemma vector_meet:
  "x * top \<sqinter> y \<le> d(x) * y"
  by (metis d_galois d_mult_sub inf.sup_monoid.add_commute inf.sup_right_isotone meet_domain_top)

end

class domain_semiring_lattice_L = domain_semiring_lattice + L +
  assumes l1: "x * L = x * bot \<squnion> d(x) * L"
  assumes l2: "d(L) * x \<le> x * d(L)"
  assumes l3: "d(L) * top \<le> L \<squnion> d(L * bot) * top"
  assumes l4: "L * top \<le> L"
  assumes l5: "x * bot \<sqinter> L \<le> (x \<sqinter> L) * bot"
begin

lemma l8:
  "(x \<sqinter> L) * bot \<le> x * bot \<sqinter> L"
  by (meson inf.boundedE inf.boundedI mult_right_sub_dist_inf_left zero_right_mult_decreasing)

lemma l9:
  "x * bot \<sqinter> L \<le> d(x * bot) * L"
  by (metis vector_meet vector_mult_closed zero_vector)

lemma l10:
  "L * L = L"
  by (metis d_restrict_equals l1 le_iff_sup zero_right_mult_decreasing)

lemma l11:
  "d(x) * L \<le> x * L"
  by (metis l1 sup.cobounded2)

lemma l12:
  "d(x * bot) * L \<le> x * bot"
  by (metis sup_right_divisibility l1 mult_assoc mult_left_zero)

lemma l13:
  "d(x * bot) * L \<le> x"
  using l12 order_trans zero_right_mult_decreasing by blast

lemma l14:
  "x * L \<le> x * bot \<squnion> L"
  by (metis d_mult_below l1 sup_right_isotone)

lemma l15:
  "x * d(y) * L = x * bot \<squnion> d(x * y) * L"
  by (metis d_commutative d_mult_d d_zero l1 mult_assoc mult_left_zero)

lemma l16:
  "x * top \<sqinter> L \<le> x * L"
  using inf.order_lesseq_imp l11 vector_meet by blast

lemma l17:
  "d(x) * L \<le> d(x * L) * L"
  by (metis d_mult_below l11 le_infE le_infI meet_intro_domain)

lemma l18:
  "d(x) * L = d(x * L) * L"
  by (simp add: order.antisym d_mult_sub l17 mult_left_isotone)

lemma l19:
  "d(x * top * bot) * L \<le> d(x * L) * L"
  by (metis d_mult_sub l18 mult_assoc mult_left_isotone)

lemma l20:
  "x \<le> y \<longleftrightarrow> x \<le> y \<squnion> L \<and> x \<le> y \<squnion> d(y * bot) * top"
  apply (rule iffI)
  apply (simp add: le_supI1)
  by (smt sup_commute sup_inf_distrib1 l13 le_iff_sup meet_domain_top)

lemma l21:
  "d(x * bot) * L \<le> x * bot \<sqinter> L"
  by (simp add: d_mult_below l12)

lemma l22:
  "x * bot \<sqinter> L = d(x * bot) * L"
  using l21 order.antisym l9 by auto

lemma l23:
  "x * top \<sqinter> L = d(x) * L"
  apply (rule order.antisym)
  apply (simp add: vector_meet)
  by (metis d_mult_below inf.le_sup_iff inf_top.left_neutral l1 le_supE mult_left_sub_dist_inf_left)

lemma l29:
  "L * d(L) = L"
  by (metis d_preserves_equation d_restrict_equals l2)

lemma l30:
  "d(L) * x \<le> (x \<sqinter> L) \<squnion> d(L * bot) * x"
  by (metis inf.sup_right_divisibility inf_left_commute inf_sup_distrib1 l3 meet_domain_top)

lemma l31:
  "d(L) * x = (x \<sqinter> L) \<squnion> d(L * bot) * x"
  by (smt (z3) l30 d_dist_sup le_iff_sup meet_intro_domain semiring.combine_common_factor sup_commute sup_inf_absorb zero_right_mult_decreasing)

lemma l40:
  "L * x \<le> L"
  by (meson bot_least inf.order_trans l4 semiring.mult_left_mono top.extremum)

lemma l41:
  "L * top = L"
  by (simp add: l40 order.antisym top_right_mult_increasing)

lemma l50:
  "x * bot \<sqinter> L = (x \<sqinter> L) * bot"
  using order.antisym l5 l8 by force

lemma l51:
  "d(x * bot) * L = (x \<sqinter> L) * bot"
  using l22 l50 by auto

lemma l90:
  "L * top * L = L"
  by (simp add: l41 l10)

lemma l91:
  assumes "x = x * top"
    shows "d(L * bot) * x \<le> d(x * bot) * top"
proof -
  have "d(L * bot) * x \<le> d(d(L * bot) * x) * top"
    using d_galois by blast
  also have "... = d(d(L * bot) * d(x)) * top"
    using d_mult_d by auto
  also have "... = d(d(x) * L * bot) * top"
    using d_commutative d_mult_d ils.il_inf_associative by auto
  also have "... \<le> d(x * L * bot) * top"
    by (metis d_isotone l11 mult_left_isotone)
  also have "... \<le> d(x * top * bot) * top"
    by (simp add: d_isotone mult_left_isotone mult_right_isotone)
  finally show ?thesis
    using assms by auto
qed

lemma l92:
  assumes "x = x * top"
    shows "d(L * bot) * x \<le> d((x \<sqinter> L) * bot) * top"
proof -
  have "d(L * bot) * x = d(L) * d(L * bot) * x"
    using d_commutative d_mult_sub d_order by auto
  also have "... \<le> d(L) * d(x * bot) * top"
    by (metis assms order.eq_iff l91 mult_assoc mult_isotone)
  also have "... = d(d(x * bot) * L) * top"
    by (simp add: d_commutative d_export)
  also have "... \<le> d((x \<sqinter> L) * bot) * top"
    by (simp add: l51)
  finally show ?thesis
    .
qed

end

class domain_itering_lattice_L = bounded_itering + domain_semiring_lattice_L
begin

lemma mult_L_circ:
  "(x * L)\<^sup>\<circ> = 1 \<squnion> x * L"
  by (metis circ_back_loop_fixpoint circ_mult l40 le_iff_sup mult_assoc)

lemma mult_L_circ_mult_below:
  "(x * L)\<^sup>\<circ> * y \<le> y \<squnion> x * L"
  by (smt sup_right_isotone l40 mult_L_circ mult_assoc mult_left_one mult_right_dist_sup mult_right_isotone)

lemma circ_L:
  "L\<^sup>\<circ> = L \<squnion> 1"
  by (metis sup_commute l10 mult_L_circ)

lemma circ_d0_L:
  "x\<^sup>\<circ> * d(x * bot) * L = x\<^sup>\<circ> * bot"
  by (metis sup_bot_right circ_loop_fixpoint circ_plus_same d_zero l15 mult_assoc mult_left_zero)

lemma d0_circ_left_unfold:
  "d(x\<^sup>\<circ> * bot) = d(x * x\<^sup>\<circ> * bot)"
  by (metis sup_commute sup_bot_left circ_loop_fixpoint mult_assoc)

lemma d_circ_import:
  "d(y) * x \<le> x * d(y) \<Longrightarrow> d(y) * x\<^sup>\<circ> = d(y) * (d(y) * x)\<^sup>\<circ>"
  apply (rule order.antisym)
  apply (simp add: circ_import d_idempotent d_plus_one le_iff_sup)
  using circ_isotone d_mult_below mult_right_isotone by auto

end

class domain_omega_algebra_lattice_L = bounded_left_zero_omega_algebra + domain_semiring_lattice_L
begin

lemma mult_L_star:
  "(x * L)\<^sup>\<star> = 1 \<squnion> x * L"
  by (metis l40 le_iff_sup mult_assoc star.circ_back_loop_fixpoint star.circ_mult)

lemma mult_L_omega:
  "(x * L)\<^sup>\<omega> \<le> x * L"
  by (metis l40 mult_right_isotone omega_slide)

lemma mult_L_sup_star:
  "(x * L \<squnion> y)\<^sup>\<star> = y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L"
proof (rule order.antisym)
  have "(x * L \<squnion> y) * (y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L) = x * L * (y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L) \<squnion> y * (y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L)"
    by (simp add: mult_right_dist_sup)
  also have "... \<le> x * L \<squnion> y * (y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L)"
    by (metis sup_left_isotone l40 mult_assoc mult_right_isotone)
  also have "... \<le> x * L \<squnion> y * y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L"
    by (smt sup_assoc sup_commute sup_ge2 mult_assoc mult_left_dist_sup star.circ_loop_fixpoint)
  also have "... \<le> x * L \<squnion> y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L"
    by (meson order_refl star.left_plus_below_circ sup_mono)
  also have "... = y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L"
    by (metis sup_assoc sup_commute mult_assoc star.circ_loop_fixpoint star.circ_reflexive star.circ_sup_one_right_unfold star_involutive)
  finally have "1 \<squnion> (x * L \<squnion> y) * (y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L) \<le> y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L"
    by (meson le_supI le_supI1 star.circ_reflexive)
  thus "(x * L \<squnion> y)\<^sup>\<star> \<le> y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L"
    using star_left_induct by fastforce
next
  show "y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L \<le> (x * L \<squnion> y)\<^sup>\<star>"
    by (metis sup_commute le_sup_iff mult_assoc star.circ_increasing star.circ_mult_upper_bound star.circ_sub_dist)
qed

lemma mult_L_sup_omega:
  "(x * L \<squnion> y)\<^sup>\<omega> \<le> y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * x * L"
proof -
  have 1: "(y\<^sup>\<star> * x * L)\<^sup>\<omega> \<le> y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * x * L"
    by (simp add: le_supI2 mult_L_omega)
  have "(y\<^sup>\<star> * x * L)\<^sup>\<star> * y\<^sup>\<omega> \<le> y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * x * L"
    by (metis sup_right_isotone l40 mult_assoc mult_right_isotone star_left_induct)
  thus ?thesis
    using 1 by (simp add: ils.il_inf_associative omega_decompose sup_monoid.add_commute)
qed

end

sublocale domain_omega_algebra_lattice_L < dL_star: itering where circ = star ..

sublocale domain_omega_algebra_lattice_L < dL_star: domain_itering_lattice_L where circ = star ..

context domain_omega_algebra_lattice_L
begin

lemma d0_star_below_d0_omega:
  "d(x\<^sup>\<star> * bot) \<le> d(x\<^sup>\<omega> * bot)"
  by (simp add: d_isotone star_bot_below_omega_bot)

lemma d0_below_d0_omega:
  "d(x * bot) \<le> d(x\<^sup>\<omega> * bot)"
  by (metis d0_star_below_d0_omega d_isotone mult_left_isotone order_trans star.circ_increasing)

lemma star_L_split:
  assumes "y \<le> z"
      and "x * z * L \<le> x * bot \<squnion> z * L"
    shows "x\<^sup>\<star> * y * L \<le> x\<^sup>\<star> * bot \<squnion> z * L"
proof -
  have "x * (x\<^sup>\<star> * bot \<squnion> z * L) \<le> x\<^sup>\<star> * bot \<squnion> x * z * L"
    by (metis sup_bot_right order.eq_iff mult_assoc mult_left_dist_sup star.circ_loop_fixpoint)
  also have "... \<le> x\<^sup>\<star> * bot \<squnion> x * bot \<squnion> z * L"
    using assms(2) semiring.add_left_mono sup_monoid.add_assoc by auto
  also have "... = x\<^sup>\<star> * bot \<squnion> z * L"
    using mult_isotone star.circ_increasing sup.absorb_iff1 by force
  finally have "y * L \<squnion> x * (x\<^sup>\<star> * bot \<squnion> z * L) \<le> x\<^sup>\<star> * bot \<squnion> z * L"
    by (simp add: assms(1) le_supI1 mult_left_isotone sup_monoid.add_commute)
  thus ?thesis
    by (simp add: star_left_induct mult.assoc)
qed

lemma star_L_split_same:
  "x * y * L \<le> x * bot \<squnion> y * L \<Longrightarrow> x\<^sup>\<star> * y * L = x\<^sup>\<star> * bot \<squnion> y * L"
  apply (rule order.antisym)
  using star_L_split apply blast
  by (metis bot_least ils.il_inf_associative le_supI mult_isotone mult_left_one order_refl star.circ_reflexive)

lemma star_d_L_split_equal:
  "d(x * y) \<le> d(y) \<Longrightarrow> x\<^sup>\<star> * d(y) * L = x\<^sup>\<star> * bot \<squnion> d(y) * L"
  by (metis sup_right_isotone l15 le_iff_sup mult_right_sub_dist_sup_left star_L_split_same)

lemma d0_omega_mult:
  "d(x\<^sup>\<omega> * y * bot) = d(x\<^sup>\<omega> * bot)"
  apply (rule order.antisym)
  apply (simp add: d_isotone mult_isotone omega_sub_vector)
  by (metis d_isotone mult_assoc mult_right_isotone bot_least)

lemma d_omega_export:
  "d(y) * x \<le> x * d(y) \<Longrightarrow> d(y) * x\<^sup>\<omega> = (d(y) * x)\<^sup>\<omega>"
  apply (rule order.antisym)
  apply (simp add: d_preserves_equation omega_simulation)
  by (smt le_iff_sup mult_left_dist_sup omega_simulation_2 omega_slide)

lemma d_omega_import:
  "d(y) * x \<le> x * d(y) \<Longrightarrow> d(y) * x\<^sup>\<omega> = d(y) * (d(y) * x)\<^sup>\<omega>"
  using d_idempotent omega_import order.refl by auto

lemma star_d_omega_top:
  "x\<^sup>\<star> * d(x\<^sup>\<omega>) * top = x\<^sup>\<star> * bot \<squnion> d(x\<^sup>\<omega>) * top"
  apply (rule order.antisym)
  apply (metis le_supI2 mult_domain_top star_mult_omega)
  by (metis ils.il_inf_associative le_supI mult_left_one mult_left_sub_dist_sup_right mult_right_sub_dist_sup_left star.circ_right_unfold_1 sup_monoid.add_0_right)

lemma omega_meet_L:
  "x\<^sup>\<omega> \<sqinter> L = d(x\<^sup>\<omega>) * L"
  by (metis l23 omega_vector)

proposition d_star_mult: "d(x * y) \<le> d(y) \<Longrightarrow> d(x\<^sup>\<star> * y) = d(x\<^sup>\<star> * bot) \<squnion> d(y)" oops
proposition d0_split_omega_omega: "x\<^sup>\<omega> \<le> x\<^sup>\<omega> * bot \<squnion> d(x\<^sup>\<omega> \<sqinter> L) * top" nitpick [expect=genuine,card=2] oops

end

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_nat_QSortIsSort
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun lt :: "Nat => Nat => bool" where
  "lt y (Z) = False"
| "lt (Z) (S z2) = True"
| "lt (S n) (S z2) = lt n z2"

fun le :: "Nat => Nat => bool" where
  "le (Z) z = True"
| "le (S z2) (Z) = False"
| "le (S z2) (S x2) = le z2 x2"

fun insert :: "Nat => Nat list => Nat list" where
  "insert y (nil2) = cons2 y (nil2)"
| "insert y (cons2 z2 xs) =
     (if le y z2 then cons2 y (cons2 z2 xs) else
        cons2 z2 (insert y xs))"

fun isort :: "Nat list => Nat list" where
  "isort (nil2) = nil2"
| "isort (cons2 z xs) = insert z (isort xs)"

fun gt :: "Nat => Nat => bool" where
  "gt y z = lt z y"

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

(*fun did not finish the proof*)
function qsort :: "Nat list => Nat list" where
  "qsort (nil2) = nil2"
| "qsort (cons2 z xs) =
     x (qsort (filter (% (z2 :: Nat) => le z2 z) xs))
       (x (cons2 z (nil2))
          (qsort (filter (% (x2 :: Nat) => gt x2 z) xs)))"
  by pat_completeness auto

theorem property0 :
  "((qsort xs) = (isort xs))"
  oops

end


theory LTree
imports Main  "$AFP/Coinductive/Coinductive_List"
begin

codatatype (lset: 'a) tree = Node (nxt : "'a \<Rightarrow> 'a tree option")

primcorec empty :: "'a tree"
  where "nxt empty = (\<lambda> _ . None)"

primcorec single :: "'a \<Rightarrow> 'a tree"
  where "nxt (single x) = (\<lambda> _ . None)(x := Some empty)"

primcorec many :: "'a \<Rightarrow> 'a tree"
  where "nxt (many x) = (\<lambda> x'. if x' = x then Some (many x) else None)"

primcorec anything :: "'a tree"
  where "nxt anything = (\<lambda> _ . Some anything)"

coinductive paths_aux :: "'a tree \<Rightarrow> 'a llist \<Rightarrow> bool"
  where "paths_aux t LNil"
      | "nxt t x = Some t' \<Longrightarrow> paths_aux t' l \<Longrightarrow> paths_aux t (LCons x l)"

definition paths :: "'a tree \<Rightarrow> 'a llist set"
  where "paths t = Collect (paths_aux t)"
lemma elim_paths_aux[pred_set_conv]: "paths_aux t p \<longleftrightarrow> p \<in> paths t" unfolding paths_def by simp
lemmas paths_intros[intro?] = paths_aux.intros[unfolded elim_paths_aux]
lemmas paths_coinduct[consumes 1, coinduct set: paths] = paths_aux.coinduct[to_set]
lemmas paths_cases[consumes 1, cases set: paths] = paths_aux.cases[to_set]
lemmas paths_simpss = paths_aux.simps[to_set]

lemma "repeat x \<in> paths (many x)"
  apply (coinduction)
  apply (rule disjI2)
  apply auto
  apply (rule exI[where x = "repeat x"])
  apply auto
  apply (rule iterates)
  done

fun op_option :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a option \<Rightarrow> 'a option \<Rightarrow> 'a option"
  where "op_option f (Some x) (Some y) = Some (f x y)"
      | "op_option f (Some x) None     = Some x"
      | "op_option f None     (Some y) = Some y"
      | "op_option f None     None     = None"
(*
primcorec or :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree"
  where "nxt (or t1 t2) = (\<lambda> x. op_option or (nxt t1 x) (nxt t2 x))"
*)
primcorec or :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree"
  where "nxt (or t1 t2) = (\<lambda> x.
           case (nxt t1 x) of Some t1' \<Rightarrow> (case nxt t2 x of Some t2' \<Rightarrow> Some (or t1' t2') | None \<Rightarrow> Some t1')
                              | None     \<Rightarrow> nxt t2 x)"

lemma or_simp:  "nxt (or t1 t2) x =  op_option or (nxt t1 x) (nxt t2 x)"
  by (cases "nxt t1 x", case_tac [!] "nxt t2 x") auto

(*
primcorec and_aux :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree"
      and and :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree"
  where "(and_aux t1 t2) = Node (\<lambda> x. case (nxt t1 x) of Some t1' \<Rightarrow> Some (and t1' t2) | None \<Rightarrow> None)"
       |"(and t1 t2) = or (and_aux t1 t2) (and_aux t2 t1)"

primcorec and :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree"
   where "(and t1 t2) = or (Node (\<lambda> x. case (nxt t1 x) of Some t1' \<Rightarrow> Some (and t1' t2) | None \<Rightarrow> None)) (Node (\<lambda> x. case (nxt t1 x) of Some t1' \<Rightarrow> Some (and t1' t2) | None \<Rightarrow> None))"

primcorec and :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree"
   where "nxt (and t1 t2) = (\<lambda> x.
      case (nxt t1 x) of Some t1' \<Rightarrow> (case nxt t2 x of Some t2' \<Rightarrow> Some (or (and t1' t2) (and t1 t2')) | None \<Rightarrow> Some (and t1' t2))
                         | None     \<Rightarrow> (case nxt t2 x of Some t2' \<Rightarrow> Some (and t1 t2')                     | None \<Rightarrow> None))"

primcorec and :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree"
   where "nxt (and t1 t2) = map_option (\<lambda> (x,y). (and x y, and x y)) o (\<lambda> x.
      case (nxt t1 x) of Some t1' \<Rightarrow> (case nxt t2 x of Some t2' \<Rightarrow> Some (or t1' t1, or t2 t2') | None \<Rightarrow> Some (t1', t2))
                         | None     \<Rightarrow> (case nxt t2 x of Some t2' \<Rightarrow> Some (t1, t2')                | None \<Rightarrow> None))"
*)

end