section \<open> Morgan's Relational Refinement Calculus \<close>

theory morgan_rcalc
  imports "UTP.utp"
begin

subsection \<open> Specification Statement \<close>

definition spec :: "('a \<Longrightarrow> 's) \<Rightarrow> 's upred \<Rightarrow> 's upred \<Rightarrow> 's hrel" ("_:[_,_]" [900, 0, 0] 900) where
[upred_defs]: "spec w p q = (p\<^sup>< \<Rightarrow> q\<^sup>> \<and> $\<^bold>v\<acute> =\<^sub>u $\<^bold>v \<oplus> $\<^bold>v\<acute> on &w)"

utp_lift_notation spec (1 2)

subsection \<open> Refinement Laws \<close>

lemma strengthen_post:
  assumes "`post' \<Rightarrow> post`"
  shows "w:[pre, post] \<sqsubseteq> w:[pre, post']"
  using assms by (rel_auto)

lemma weaken_pre:
  assumes "`pre \<Rightarrow> pre'`"
  shows "w:[pre, post] \<sqsubseteq> w:[pre', post]"
  using assms by (rel_auto)

lemma refine_skip:
  assumes "vwb_lens w" "`pre \<Rightarrow> post`"
  shows "w:[pre, post] \<sqsubseteq> II"
  using assms by (rel_auto)

lemma refine_assign:
  assumes "vwb_lens w" "vwb_lens x" "x \<subseteq>\<^sub>L w" "`pre \<Rightarrow> post\<lbrakk>e/x\<rbrakk>`"
  shows "w:[pre, post] \<sqsubseteq> x := e"
  using assms by (rel_auto)

lemma assign_is_spec:
  assumes "vwb_lens w" "w \<sharp> e"
  shows "(w := e) = w:[true, &w = e]"
  using assms by (rel_auto, metis)

lemma refine_seq:
  "vwb_lens a \<Longrightarrow> a:[pre, post] \<sqsubseteq> a:[pre, mid] ;; a:[mid, post]"
  by (rel_simp, metis vwb_lens.put_eq)

lemma refine_assign_follow:
  assumes "vwb_lens w" "vwb_lens x" "x \<subseteq>\<^sub>L w"
  shows "w:[pre, post] \<sqsubseteq> w:[pre, post\<lbrakk>e/x\<rbrakk>] ;; x := e"
  using assms
  by (rel_auto, metis (no_types, lifting) mwb_lens.put_put vwb_lens_mwb)

lemma refine_frame:
  "\<lbrakk> vwb_lens x; x \<bowtie> w \<rbrakk> \<Longrightarrow> {x,w}\<^sub>v:[pre, post] \<sqsubseteq> w:[pre, post]"
  by (rel_simp)

lemma refine_cond:
  "x:[pre, post] \<sqsubseteq> x:[b \<and> pre, post] \<triangleleft> b \<triangleright>\<^sub>r x:[\<not>b \<and> pre, post]"
  by (rel_auto)

theorem refine_hoare_link: "\<^bold>{pre\<^bold>}P\<^bold>{post\<^bold>} \<longleftrightarrow> 1\<^sub>L:[pre, post] \<sqsubseteq> P"
  by rel_auto

subsection \<open> Examples \<close>

alphabet ss = x :: real y :: real

abbreviation (input) "s1 \<equiv> y:[0 \<le> x \<and> x \<le> 9, y\<^sup>2 = x]"
abbreviation (input) "s2 \<equiv> y:[0 \<le> x \<and> x \<le> 9, y\<^sup>2 = x \<and> 0 \<le> y]"

lemma "s1 \<sqsubseteq> s2"
  apply (rule strengthen_post)
  apply (rel_auto)
  done

abbreviation (input) "s3 \<equiv> y:[0 \<le> x, y\<^sup>2 = x \<and> 0 \<le> y]"

lemma "s2 \<sqsubseteq> s3"
  apply (rule weaken_pre)
  apply (rel_auto)
  done

lemma "s3 \<sqsubseteq> y := sqrt(x)"
  apply (rule refine_assign)
     apply (simp_all)
  apply (rel_auto)
  done

alphabet sse = ss + t::real

end


(* This file includes our top-level hybrid algorithm (which uses
  the algorithm defined in Hybrid_Multiv_Matrix.thy as a component).
*)

theory Hybrid_Multiv_Algorithm

imports Hybrid_Multiv_Matrix
  Virtual_Substitution.ExportProofs

begin

section "Most recent code"
  (* Invariant: For all (a, q) in the output, either
  q is 0 or the leading coefficient of q is assumed nonzero in a *)
function lc_assump_generation:: "rmpoly \<Rightarrow> assumps\<Rightarrow> (assumps \<times> rmpoly) list"
  where "lc_assump_generation q assumps =
     (if q = 0 then [(assumps, 0)] else
     (case (lookup_assump_aux (Polynomial.lead_coeff q) assumps) of
      None \<Rightarrow>
        let zero = lc_assump_generation (one_less_degree q) ((Polynomial.lead_coeff q, (0::rat)) # assumps);
            one  = ((Polynomial.lead_coeff q, (1::rat)) # assumps, q);
            minus_one  = ((Polynomial.lead_coeff q, (-1::rat)) # assumps, q) in
          one#minus_one#zero
      | (Some i) \<Rightarrow>
        (if i = 0 then lc_assump_generation (one_less_degree q) assumps
        else
         [(assumps, q)]
        )
  )) "
  by auto
termination apply (relation  "measure (\<lambda>(q, assumps). (let w = (if q \<noteq> 0 then 1 else 0) in w + Polynomial.degree q))")
    apply (auto) using one_less_degree_degree
   apply (smt (verit, del_insts) Multiv_Poly_Props.one_less_degree_def Polynomial.coeff_diff Polynomial.lead_coeff_monom cancel_comm_monoid_add_class.diff_cancel coeff_eq_0 degree_monom_eq leading_coeff_neq_0 linorder_neqE_nat)
  using one_less_degree_degree
  by (smt (verit) Multiv_Poly_Props.one_less_degree_def Polynomial.coeff_diff Polynomial.lead_coeff_monom cancel_comm_monoid_add_class.diff_cancel coeff_eq_0 degree_monom_eq leading_coeff_neq_0 linorder_neqE_nat)

declare lc_assump_generation.simps[simp del]

value "lc_assump_generation ([:Var 1:]::rmpoly) [(Var 1, 1)]"

fun lc_assump_generation_list:: "rmpoly list \<Rightarrow> assumps \<Rightarrow> (assumps \<times> rmpoly list) list"
  where "lc_assump_generation_list [] assumps = [(assumps, [])]"
  | "lc_assump_generation_list (q#qs) assumps = (let rec = lc_assump_generation q assumps in
    concat (map (
      \<lambda>(new_assumps, r). (let list_rec = lc_assump_generation_list qs new_assumps in
      map (\<lambda>elem. (fst elem, r#(snd elem))) list_rec) ) rec ))"

declare lc_assump_generation_list.simps[simp del]

value "lc_assump_generation_list [([:Var 1:]::rmpoly), ([:Var 1:]::rmpoly)] []"

value "(lc_assump_generation_list [([:Var 1:]::rmpoly)] []) ! 1"

definition poly_p:: "rmpoly list \<Rightarrow> rmpoly"
  where "poly_p qs = (let prod_list = prod_list qs in
    prod_list*(pderiv prod_list))"

primrec check_all_const_deg_gen:: "('a::zero) Polynomial.poly list \<Rightarrow> bool"
  where "check_all_const_deg_gen  [] = True"
  | "check_all_const_deg_gen (h#T) = (if Polynomial.degree h = 0 then (check_all_const_deg_gen T) else False)"

primrec prod_list_var_gen:: "('a::idom) list \<Rightarrow> ('a::idom)"
  where "prod_list_var_gen [] = 1"
  | "prod_list_var_gen (h#T) = (if h = 0 then (prod_list_var_gen T) else (h* prod_list_var_gen T))"

fun poly_p_in_branch:: "(assumps \<times> rmpoly list) \<Rightarrow> rmpoly"
  where "poly_p_in_branch (assumps, qs) =
 (if (check_all_const_deg_gen qs = True) then  [:0, 1:] else
  (pderiv (prod_list_var_gen qs)) * (prod_list_var_gen qs)
)"

fun limit_points_on_branch:: "(assumps \<times> rmpoly list) \<Rightarrow> (rat list \<times> rat list)"
  where "limit_points_on_branch (assumps, qs) =
    (map (\<lambda>q. if q = 0 then 0 else (rat_of_int \<circ> Sturm_Tarski.sign) (lookup_assump (Polynomial.lead_coeff q) assumps)) qs,
    map (\<lambda>q. if q = 0 then 0 else (rat_of_int \<circ> Sturm_Tarski.sign) (lookup_assump (Polynomial.lead_coeff q) assumps)*(-1)^(Polynomial.degree q)) qs)"

(* value "map limit_points_on_branch (lc_assump_generation_list [([:Var 1:]::rmpoly), ([:Var 1:]::rmpoly)] [])" *)

fun extract_signs:: "(assumps \<times> matrix_equation) list \<Rightarrow> (assumps \<times> rat list list) list"
  where "extract_signs qs = map (\<lambda>(assumps, (mat , (subs, signs))). (assumps, signs)) qs"

fun sign_determination_inner:: "rmpoly list \<Rightarrow> assumps \<Rightarrow> (assumps \<times> rat list list) list"
  where "sign_determination_inner qs assumps =
( let branches = lc_assump_generation_list qs assumps  in
concat (map (\<lambda>branch.
let poly_p_branch = poly_p_in_branch branch;
    (pos_limit_branch, neg_limit_branch) = limit_points_on_branch branch;
    calculate_data_branch = extract_signs (calculate_data_assumps_M poly_p_branch (snd branch) (fst branch))
in map (\<lambda>(a, signs). (a, pos_limit_branch#neg_limit_branch#signs)) calculate_data_branch
) branches
))"

fun extract_polys:: "atom fm \<Rightarrow> real mpoly list"
  where "extract_polys (Atom (Less p)) = [p]" |
    "extract_polys (Atom (Leq p)) = [p]" |
    "extract_polys (Atom (Eq p)) = [p]" |
    "extract_polys (Atom (Neq p)) = [p]" |
    "extract_polys (TrueF) = []" |
    "extract_polys (FalseF) = []" |
    "extract_polys (And \<phi> \<psi>) =  (extract_polys \<phi> )@ (extract_polys \<psi>)" |
    "extract_polys (Or \<phi> \<psi>) = (extract_polys \<phi>)@(extract_polys \<psi>)" |
    "extract_polys (Neg \<phi>)  = (extract_polys \<phi>)" |
    "extract_polys (ExN 0 \<phi>)  = (extract_polys \<phi>)" |
    "extract_polys (AllN 0 \<phi>)  = (extract_polys \<phi>)" |
    "extract_polys _  = []"

(* Evaluating a formula over a lookup semantics *)
fun lookup_sem_M :: "atom fm \<Rightarrow> (real mpoly \<times> rat) list \<Rightarrow> bool option"
  where
    "lookup_sem_M TrueF ls = Some (True)"
  | "lookup_sem_M FalseF ls = Some (False)"
  |  "lookup_sem_M (And l r) ls = (case (lookup_sem_M l ls, lookup_sem_M r ls)
      of (Some i, Some j) \<Rightarrow> Some (i \<and> j)
      | _ \<Rightarrow> None)"
  | "lookup_sem_M (Or l r) ls = (case (lookup_sem_M l ls, lookup_sem_M r ls)
      of (Some i, Some j) \<Rightarrow> Some (i \<or> j)
      | _ \<Rightarrow> None)"
  | "lookup_sem_M (Neg l) ls = (case (lookup_sem_M l ls)
      of Some i \<Rightarrow> Some ((\<not>i))
      | _ \<Rightarrow> None)"
  | "lookup_sem_M (Atom (Less p)) ls =
     (case (lookup_assump_aux p ls) of
     Some i \<Rightarrow> Some (i < 0)
    | _ \<Rightarrow> None
     )"
  | "lookup_sem_M (Atom (Leq p)) ls =
     (case (lookup_assump_aux p ls) of
     Some i \<Rightarrow> Some (i \<le> 0)
    | _ \<Rightarrow> None
     )"
  | "lookup_sem_M (Atom (Eq p)) ls =
     (case (lookup_assump_aux p ls) of
     Some i \<Rightarrow> Some (i = 0)
    | _ \<Rightarrow> None
     )"
  | "lookup_sem_M (Atom (Neq p)) ls =
     (case (lookup_assump_aux p ls) of
     Some i \<Rightarrow> Some (i \<noteq> 0)
    | _ \<Rightarrow> None
     )"
  | "lookup_sem_M (ExN 0 l) ls = lookup_sem_M l ls"
  | "lookup_sem_M (AllN 0 l) ls = lookup_sem_M l ls"
  | "lookup_sem_M _ ls = None"

fun assump_to_atom:: "(real mpoly \<times> rat) \<Rightarrow> atom"
  where "assump_to_atom (p, r) =
      (if r = 0 then (Eq p)
    else (if r < 0 then (Less p)
    else (Less (-p))
  ))"

fun assump_to_atom_fm:: "assumps \<Rightarrow> atom fm"
  where "assump_to_atom_fm [] = TrueF"
  | "assump_to_atom_fm ((p, r)#T) = And (Atom (assump_to_atom (p, r))) (assump_to_atom_fm T)"

fun create_disjunction:: "(assumps \<times> rat list list) list  \<Rightarrow> atom fm"
  where "create_disjunction [] = FalseF"
  | "create_disjunction ((a, _)#T) = Or (assump_to_atom_fm a) (create_disjunction T)"

fun elim_forall:: "atom fm \<Rightarrow> atom fm"
  where "elim_forall F =
  (
    let qs = extract_polys F;
        univ_qs = univariate_in qs 0;
        reindexed_univ_qs = map (map_poly (lowerPoly 0 1)) univ_qs;
        data = sign_determination_inner reindexed_univ_qs [];
        new_data = filter (\<lambda>(assumps, signs_list).
          list_all (\<lambda> signs.
          let paired_signs = zip qs signs in
            lookup_sem_M F paired_signs = (Some True))
          signs_list
          ) data
  in create_disjunction new_data
  )"

definition elim_exist:: "atom fm \<Rightarrow> atom fm"
  where "elim_exist F = Neg (elim_forall (Neg F))"

fun structural_complexity:: "atom fm \<Rightarrow> (nat \<times> nat)"
  where
    "structural_complexity TrueF = (0, 1)"
  | "structural_complexity FalseF = (0, 1)"
  | "structural_complexity (Atom a) = (0, 1)"
  | "structural_complexity (And F1 F2) =
  (let (qF1, sF1) = structural_complexity F1;
    (qF2, sF2) = structural_complexity F2
  in (qF1 + qF2, 1 + sF1 + sF2))"
  | "structural_complexity (Or F1 F2) =
  (let (qF1, sF1) = structural_complexity F1;
    (qF2, sF2) = structural_complexity F2
  in (qF1 + qF2, 1 + sF1 + sF2))"
  | "structural_complexity (Neg F) =
  (let (qF, sF) = structural_complexity F
  in (qF, 1 + sF))"
  | "structural_complexity (ExQ F) =
  (let (qF, sF) = structural_complexity F
  in (1+ qF, 1 + sF))"
  | "structural_complexity (AllQ F) =
  (let (qF, sF) = structural_complexity F
  in (1+ qF, 1 + sF))"
  | "structural_complexity (ExN n F) =
  (let (qF, sF) = structural_complexity F
  in (2 + n+qF, 2+n+sF))"
  | "structural_complexity (AllN n F) =
  (let (qF, sF) = structural_complexity F
  in (2 + n+qF, 2+n+sF))"

declare structural_complexity.simps[simp del]

(* Can take a few seconds to load*)
fun qe:: "atom fm \<Rightarrow> atom fm"
  where
    "qe TrueF = TrueF"
  | "qe FalseF = FalseF"
  | "qe (Atom a) = (Atom a)"
  | "qe (And F1 F2) = And (qe F1) (qe F2)"
  | "qe (Or F1 F2) = Or (qe F1) (qe F2)"
  | "qe (Neg F) = Neg (qe F)"
  | "qe (ExQ F) = elim_exist (qe F)"
  | "qe (AllQ F) = elim_forall (qe F)"
  | "qe (AllN n F) = (elim_forall ^^ n) (qe F)"
  | "qe (ExN n F) = (elim_exist ^^ n) (qe F)"

definition qe_with_VS:: "atom fm \<Rightarrow> atom fm"
  where "qe_with_VS F = (qe \<circ> VSLEG) F"

value "((MPoly (Pm_fmap (fmap_of_list [(Pm_fmap (fmap_of_list []), 1)])))::real mpoly) = Const 1"

(* value "elim_forall (Atom (Less (Var 0)))"
value "elim_forall (Atom (Leq(Const (-1)*(Var 0)^2)))" *)
(* value "freeIn 0 (elim_forall (Atom (Leq(Const (-1)*(Var 0)^2))))" *)

(* eval_ground is only used for testing purposes, so we haven't proved
  anything about its correctness.
  Its purpose is to simplify the output of "qe" on fully quantified QE problems
  (sentences) to either True or False.
  It should not be used outside of this context.
 *)
fun eval_ground :: "atom fm \<Rightarrow> real list \<Rightarrow> bool" where
  "eval_ground (Atom a) \<Gamma> = aEval a \<Gamma>" |
  "eval_ground (TrueF) _ = True" |
  "eval_ground (FalseF) _ = False" |
  "eval_ground (And \<phi> \<psi>) \<Gamma> = ((eval_ground \<phi> \<Gamma>) \<and> (eval_ground \<psi> \<Gamma>))" |
  "eval_ground (Or \<phi> \<psi>) \<Gamma> = ((eval_ground \<phi> \<Gamma>) \<or> (eval_ground \<psi> \<Gamma>))" |
  "eval_ground (Neg \<phi>) \<Gamma> = (\<not> (eval_ground \<phi> \<Gamma>))"

value "VSLEG (ExQ (ExQ (Atom (Less (Var 0^2*Var 1 ::real mpoly)))))"
value "(qe_with_VS (ExQ (ExQ (Atom (Less (Var 0^2*Var 1 ::real mpoly))))))"
  (* These may not finish *)
  (* value "qe (ExQ (ExQ (Atom (Less (Var 0^2*Var 1 ::real mpoly)))))" *)
  (* value "eval_ground (qe (ExQ (Atom (Less (Var 0^4 + Var 0 + 1 ::real mpoly)))))" *)

section "Decision Portion"

fun extract_polys_from_assumps:: "assumps \<Rightarrow> real mpoly list"
  where "extract_polys_from_assumps [] = []"
  | "extract_polys_from_assumps ((p, i)#T) = p#(extract_polys_from_assumps T)"

fun assumps_are_consistent:: "assumps \<Rightarrow> rat list list \<Rightarrow> bool"
  where "assumps_are_consistent assump ls = ((map snd assump) \<in> set ls)"

(* Extract the list of consistent sign assignments from a list of matrix equations with consistent assumptions *)
fun find_consistent_signs_at_roots_single_M:: "(assumps \<times> matrix_equation) \<Rightarrow> rat list list"
  where "find_consistent_signs_at_roots_single_M (assumps, (M, (subsets, signs))) = signs"

fun find_consistent_signs_at_roots_M:: "(assumps \<times> matrix_equation) list \<Rightarrow> rat list list"
  where "find_consistent_signs_at_roots_M l = concat (map find_consistent_signs_at_roots_single_M l)"

subsection "Limit Points and Helper Functions"
definition expand_signs_list:: "real mpoly list \<Rightarrow> rat list list \<Rightarrow> (real mpoly \<times> rat) list list"
  where "expand_signs_list qs csas =  map (\<lambda>csa. zip qs csa) csas"

(* Under valuation, the lead coefficient has this sign *)
fun first_nonzero_coefficient_degree_helper:: "(real mpoly \<times> rat) list \<Rightarrow> real mpoly list \<Rightarrow> nat \<Rightarrow> (nat \<times> rat)"
  where "first_nonzero_coefficient_degree_helper assumps [] n = (n, 0)"
  | "first_nonzero_coefficient_degree_helper assumps (h # T) n =
    (case lookup_assump_aux h assumps of
         (Some i) \<Rightarrow> (if i \<noteq> 0 then (n, i) else first_nonzero_coefficient_degree_helper assumps T (n-1))
          | None \<Rightarrow> first_nonzero_coefficient_degree_helper assumps T (n-1))"

fun first_nonzero_coefficient_degree_helper_simp:: "(real mpoly \<times> rat) list \<Rightarrow> real mpoly list  \<Rightarrow> (nat \<times> rat)"
  where "first_nonzero_coefficient_degree_helper_simp assumps [] = (0, 0)"
  | "first_nonzero_coefficient_degree_helper_simp assumps (h # T) =
    (case lookup_assump_aux h assumps of
         (Some i) \<Rightarrow> (if i \<noteq> 0 then (length T, i) else first_nonzero_coefficient_degree_helper_simp assumps T)
          | None \<Rightarrow> first_nonzero_coefficient_degree_helper_simp assumps T)"

lemma first_nonzero_coefficient_degree_helper_simp:
  shows "first_nonzero_coefficient_degree_helper_simp assumps ell
    = first_nonzero_coefficient_degree_helper assumps ell (length ell - 1)"
proof (induct "ell")
  case Nil
  then show ?case
    by auto
next
  case (Cons a ell)
  moreover {
    assume *: "lookup_assump_aux a assumps = Some 0"
    then have "first_nonzero_coefficient_degree_helper_simp assumps (a # ell) =
       first_nonzero_coefficient_degree_helper assumps (a # ell) (length (a # ell) - 1)"
      using Cons.hyps
      by simp
  }
  moreover {
    assume *: "\<exists>k\<noteq>0. lookup_assump_aux a assumps = Some k"
    then obtain k where k_prop: "k\<noteq>0 \<and> lookup_assump_aux a assumps = Some k "
      by auto
    then have "first_nonzero_coefficient_degree_helper_simp assumps (a # ell) =
       first_nonzero_coefficient_degree_helper assumps (a # ell) (length (a # ell) - 1)"
      using Cons.hyps
      by simp
  }
  moreover {
    assume *: "lookup_assump_aux a assumps = None"
    then have "first_nonzero_coefficient_degree_helper_simp assumps (a # ell) =
       first_nonzero_coefficient_degree_helper assumps (a # ell) (length (a # ell) - 1)"
      by (simp add: local.Cons)
  }
  ultimately have "first_nonzero_coefficient_degree_helper_simp assumps (a # ell) =
       first_nonzero_coefficient_degree_helper assumps (a # ell) (length (a # ell) - 1)"
    by fastforce
  then show ?case by auto
qed

declare pull_out_pairs.simps [simp del]
declare construct_rhs_vector_rec_M.simps [simp del]

declare first_nonzero_coefficient_degree_helper.simps[simp del]
declare first_nonzero_coefficient_degree_helper_simp.simps[simp del]

definition sign_and_degree_of_first_nonzero_coefficient:: "(real mpoly \<times> rat) list \<Rightarrow> rmpoly \<Rightarrow> (nat \<times> rat)"
  where "sign_and_degree_of_first_nonzero_coefficient assumps q =
    first_nonzero_coefficient_degree_helper assumps (rev (Polynomial.coeffs q)) ((length (Polynomial.coeffs q)) - 1)"

definition sign_and_degree_of_first_nonzero_coefficient_simp:: "(real mpoly \<times> rat) list \<Rightarrow> rmpoly \<Rightarrow> (nat \<times> rat)"
  where "sign_and_degree_of_first_nonzero_coefficient_simp assumps q =
    first_nonzero_coefficient_degree_helper_simp assumps (rev (Polynomial.coeffs q))"

lemma sign_and_degree_of_first_nonzero_coefficient_simp:
  "sign_and_degree_of_first_nonzero_coefficient assumps q = sign_and_degree_of_first_nonzero_coefficient_simp assumps q"
  using first_nonzero_coefficient_degree_helper_simp
  by (simp add: sign_and_degree_of_first_nonzero_coefficient_def sign_and_degree_of_first_nonzero_coefficient_simp_def)

definition sign_and_degree_of_first_nonzero_coefficient_list:: "rmpoly list \<Rightarrow> (real mpoly \<times> rat) list \<Rightarrow> (nat \<times> rat) list"
  where "sign_and_degree_of_first_nonzero_coefficient_list qs assumps =
    map (\<lambda>q. sign_and_degree_of_first_nonzero_coefficient_simp assumps q) qs"

fun all_pos_limit_points:: "rmpoly list \<Rightarrow> rat list list \<Rightarrow> rat list list"
  where "all_pos_limit_points qs coeffs_signs  =
(if qs = [] then []
else (if (all_coeffs qs = []) then ([map (\<lambda>x. 0) qs])
  else
  (let expand_coeffs_signs = expand_signs_list (all_coeffs qs) coeffs_signs in
  map  ((map snd) \<circ> sign_and_degree_of_first_nonzero_coefficient_list qs) expand_coeffs_signs)))"

fun all_neg_limit_points_aux:: "(nat \<times> rat) list \<Rightarrow> rat list"
  where "all_neg_limit_points_aux deg_sign_list = map (\<lambda>(deg, sgn). (-1)^deg*sgn) deg_sign_list"

fun all_neg_limit_points:: "rmpoly list \<Rightarrow> rat list list \<Rightarrow> rat list list"
  where "all_neg_limit_points qs coeffs_signs  =
  (let expand_coeffs_signs = expand_signs_list (all_coeffs qs) coeffs_signs;
   (sgn_and_deg_list::(nat \<times> rat) list list) = map (sign_and_degree_of_first_nonzero_coefficient_list qs) expand_coeffs_signs
    in map all_neg_limit_points_aux sgn_and_deg_list)"

(*
value "all_pos_limit_points [[:Var 0, Var 1:], [:Var 1:]] [[1, 1], [-1, 1]]"
value "all_neg_limit_points [[:Var 0, Var 1:], [:Var 1:]] [[1, 1], [-1, 1]]"
*)

subsection "Top-level functions QE"

definition transform:: "real mpoly list \<Rightarrow> real mpoly Polynomial.poly list"
  where "transform qs = (let vs = variables_list qs in
   map (\<lambda>q. (mpoly_to_mpoly_poly_alt (nth vs (length vs - 1)) q)) qs)"

fun calculate_data_to_signs:: "(assumps \<times> matrix_equation) list \<Rightarrow> (assumps \<times> rat list list) list"
  where "calculate_data_to_signs ell = map (\<lambda>x. (fst x, snd (snd (snd x)))) ell"

fun sum_list:: "nat list \<Rightarrow> nat"
  where "sum_list [] = 0"
  | "sum_list (a # ell) = a + (sum_list ell)"

fun limit_point_data:: "(rat \<times> nat) list \<Rightarrow> (rat list \<times> rat list)"
  where "limit_point_data ell = (map fst ell, map (\<lambda>x. fst x * (-1)^(snd x)) ell)"

fun generate_signs_and_assumptions:: "rmpoly list \<Rightarrow> (assumps \<times> rat list list) list"
  where "generate_signs_and_assumptions qs_univ =
    (let p = poly_p qs_univ; calc_data = calculate_data_M p qs_univ in [])"

(* This generates the code export.  Note that the resulting SML code
  has to be slightly instrumented before it will run. *)
export_code calculate_data_assumps_M qe VSLEG add mult C V pow minus
  real_of_int real_mult real_plus real_minus real_div print_mpoly
  eval_ground
  in SML module_name export

end


(*  Title:      HOL/TLA/Buffer/Buffer.thy
    Author:     Stephan Merz, University of Munich
*)

section \<open>A simple FIFO buffer (synchronous communication, interleaving)\<close>

theory Buffer
imports "../TLA"
begin

(* actions *)

definition BInit :: "'a stfun \<Rightarrow> 'a list stfun \<Rightarrow> 'a stfun \<Rightarrow> stpred"
  where "BInit ic q oc == PRED q = #[]"

definition Enq :: "'a stfun \<Rightarrow> 'a list stfun \<Rightarrow> 'a stfun \<Rightarrow> action"
  where "Enq ic q oc == ACT (ic$ \<noteq> $ic)
                         \<and> (q$ = $q @ [ ic$ ])
                         \<and> (oc$ = $oc)"

definition Deq :: "'a stfun \<Rightarrow> 'a list stfun \<Rightarrow> 'a stfun \<Rightarrow> action"
  where "Deq ic q oc == ACT ($q \<noteq> #[])
                         \<and> (oc$ = hd< $q >)
                         \<and> (q$ = tl< $q >)
                         \<and> (ic$ = $ic)"

definition Next :: "'a stfun \<Rightarrow> 'a list stfun \<Rightarrow> 'a stfun \<Rightarrow> action"
  where "Next ic q oc == ACT (Enq ic q oc \<or> Deq ic q oc)"

(* temporal formulas *)

definition IBuffer :: "'a stfun \<Rightarrow> 'a list stfun \<Rightarrow> 'a stfun \<Rightarrow> temporal"
  where "IBuffer ic q oc == TEMP Init (BInit ic q oc)
                                  \<and> \<box>[Next ic q oc]_(ic,q,oc)
                                  \<and> WF(Deq ic q oc)_(ic,q,oc)"

definition Buffer :: "'a stfun \<Rightarrow> 'a stfun \<Rightarrow> temporal"
  where "Buffer ic oc == TEMP (\<exists>\<exists>q. IBuffer ic q oc)"

(* ---------------------------- Data lemmas ---------------------------- *)

(*FIXME: move to theory List? Maybe as (tl xs = xs) = (xs = [])"?*)
lemma tl_not_self [simp]: "xs \<noteq> [] \<Longrightarrow> tl xs \<noteq> xs"
  by (auto simp: neq_Nil_conv)

(* ---------------------------- Action lemmas ---------------------------- *)

(* Dequeue is visible *)
lemma Deq_visible: "\<turnstile> <Deq ic q oc>_(ic,q,oc) = Deq ic q oc"
  apply (unfold angle_def Deq_def)
  apply (safe, simp (asm_lr))+
  done

(* Enabling condition for dequeue -- NOT NEEDED *)
lemma Deq_enabled:
    "\<And>q. basevars (ic,q,oc) \<Longrightarrow> \<turnstile> Enabled (<Deq ic q oc>_(ic,q,oc)) = (q \<noteq> #[])"
  apply (unfold Deq_visible [temp_rewrite])
  apply (force elim!: base_enabled [temp_use] enabledE [temp_use] simp: Deq_def)
  done

(* For the left-to-right implication, we don't need the base variable stuff *)
lemma Deq_enabledE:
    "\<turnstile> Enabled (<Deq ic q oc>_(ic,q,oc)) \<longrightarrow> (q \<noteq> #[])"
  apply (unfold Deq_visible [temp_rewrite])
  apply (auto elim!: enabledE simp add: Deq_def)
  done

end


theory SimpleTank
  imports
    VDMRT
    SimpleFMI
    "UTP-Hybrid.utp_hybrid"
    "UTP-Reactive.utp_rea_hoare"
begin recall_syntax

alphabet tank_st =
  valve   :: bool
  level   :: real

alphabet ctr_st = vrt_st +
  valveOn     :: bool
  levelSensor :: real

alphabet wt_st =
  tank  :: tank_st
  ctr   :: "ctr_st vrt_st_scheme"

definition
  "Init = [ &tank:valve      \<mapsto>\<^sub>s true
          , &tank:level      \<mapsto>\<^sub>s 0
          , &ctr:valveOn     \<mapsto>\<^sub>s true
          , &ctr:levelSensor \<mapsto>\<^sub>s 0 ]"

definition
  "Wiring = [ &tank:valve      \<mapsto>\<^sub>s &ctr:valveOn
            , &ctr:levelSensor \<mapsto>\<^sub>s &tank:level ]"

lemma tank_st_ords [usubst]: "level \<prec>\<^sub>v valve"
  by (simp add: var_name_ord_def)

setup_lifting type_definition_tank_st_ext

text {* Proof that the state-space is a T2 topological space. *}

instantiation tank_st_ext :: (t2_space) t2_space
begin
  lift_definition open_tank_st_ext :: "'a tank_st_scheme set \<Rightarrow> bool" is "open" .
  instance by (intro_classes, (transfer, auto simp add: separation_t2)+)
end

lemma continuous_Rep_tank_st_ext [continuous_intros]:
  "continuous_on UNIV Rep_tank_st_ext"
  by (metis continuous_on_open_vimage image_vimage_eq open_Int open_UNIV open_tank_st_ext.rep_eq)

lemma ctr_st_ords [usubst]:
  "ctdown \<prec>\<^sub>v levelSensor"
  "ctdown \<prec>\<^sub>v valveOn"
  "levelSensor \<prec>\<^sub>v valveOn"
  by (simp_all add: var_name_ord_def)

lemma wt_st_ords [usubst]: "ctr \<prec>\<^sub>v tank"
  by (simp add: var_name_ord_def)

abbreviation (input) tank_ode_1 :: "real \<Rightarrow> real \<Rightarrow> real" where
"tank_ode_1 \<equiv> (\<lambda> t l. 1)"

abbreviation (input) tank_ode_2 :: "real \<Rightarrow> real \<Rightarrow> real" where
"tank_ode_2 \<equiv> (\<lambda> t l. -1)"

abbreviation (input) tank_sol_1 :: "real \<Rightarrow> real \<Rightarrow> real" where
"tank_sol_1 \<equiv> (\<lambda> l\<^sub>0 t. l\<^sub>0 + t)"

abbreviation (input) tank_sol_2 :: "real \<Rightarrow> real \<Rightarrow> real" where
"tank_sol_2 \<equiv> (\<lambda> l\<^sub>0 t. l\<^sub>0 - t)"

lemma tank_ode_usol_1:
  "l > 0 \<Longrightarrow> (tank_sol_1 l\<^sub>0 usolves_ode tank_ode_1 from 0) {0..l} UNIV"
  by (linear_ode)

lemma tank_ode_usol_2:
  "l > 0 \<Longrightarrow> (tank_sol_2 l\<^sub>0 usolves_ode tank_ode_2 from 0) {0..l} UNIV"
  by (linear_ode)

definition Tank  :: "tank_st fmu" where
  "Tank = Modelica_FMU (\<langle>&level : \<lambda>lev. -1\<rangle>\<^sub>h \<triangleleft> &valve \<triangleright>\<^sub>h \<langle>&level : \<lambda>lev. 1\<rangle>\<^sub>h)"

definition Ctr :: "real \<Rightarrow> real \<Rightarrow> ctr_st vrt_st_ext fmu" where
"Ctr minLevel maxLevel =
  VDMRT_FMU 0.001 (valveOn := false \<triangleleft> &levelSensor \<le>\<^sub>u \<guillemotleft>minLevel + 0.1\<guillemotright> \<triangleright>\<^sub>r
                   valveOn := true \<triangleleft> &levelSensor \<ge>\<^sub>u \<guillemotleft>maxLevel - 0.1\<guillemotright> \<triangleright>\<^sub>r II)"

definition WaterTank :: "real \<Rightarrow> real \<Rightarrow> wt_st trel" where
  "WaterTank minLevel maxLevel =
     FMI Init [FMU[ctr, Ctr minLevel maxLevel], FMU[tank, Tank]] (FixedStep 0.001) Wiring"

lemma ArbStep_not_empty [simp]: "\<not> ArbStep = {}"
  by (simp add: ArbStep_def)

(*
lemma "FMI Init [FMU[ctr, Ctr 1 10], FMU[tank, Tank]] (FixedStep 1) Wiring = false"
  apply (simp add: FMI_def alpha frame rpred usubst Ctr_def Tank_def FixedStep_def Init_def Step_FMUs_def seqr_assoc)
  apply (subst rea_assigns_comp)
    apply (simp_all add: closure)
  apply (simp add: rpred closure usubst)
  apply (subst rea_uplus_unfold)
      apply (simp add: rpred closure usubst)
   apply (simp add: rea_assigns_comp closure usubst frame unrest Step_VDMRT)
  apply (literalise, simp, unliteralise)
  apply (simp add: frame rpred alpha usubst unrest)
  apply (uexpr_simp simps: pos_transfer, simp add: rpred)
done
*)

lemma tank_ode_1_evolve:
  "\<langle>{&level} : tank_ode_1(ti)\<rangle>\<^sub>h = {[&level \<mapsto>\<^sub>s \<guillemotleft>(+)\<guillemotright>(&level)\<^sub>a(\<guillemotleft>ti\<guillemotright>)\<^sub>a]}\<^sub>h"
  by (ode_fsolve tank_sol_1)

lemma tank_ode_2_evolve:
  "\<langle>{&level} : tank_ode_2(ti)\<rangle>\<^sub>h = {[&level \<mapsto>\<^sub>s \<guillemotleft>(-)\<guillemotright>(&level)\<^sub>a(\<guillemotleft>ti\<guillemotright>)\<^sub>a]}\<^sub>h"
  by (ode_fsolve tank_sol_2)

lemma continuous_lens_pr_var [closure]: "continuous_lens x \<Longrightarrow> continuous_lens (pr_var x)"
  by (simp add: pr_var_def)

lemma continuous_lens_level [closure]: "continuous_lens level"
  apply (unfold_locales, simp_all add: lens_defs prod.case_eq_if)
  apply (simp add: tank_st.select_defs iso_tuple_fst_def tuple_iso_tuple_def
      tank_st_ext_Tuple_Iso_def Topological_Spaces.continuous_on_fst continuous_Rep_tank_st_ext)
  sorry

lemma Tank_Step:
  "H2T(\<langle>&level : \<lambda>lev. 1\<rangle>\<^sub>h \<triangleleft> &valve \<triangleright>\<^sub>h \<langle>&level : \<lambda>lev. - 1\<rangle>\<^sub>h) =
       (\<Sqinter> t | 0 <\<^sub>u \<guillemotleft>t\<guillemotright> \<bullet> wait\<^sub>r \<guillemotleft>t\<guillemotright> ;; (level :=\<^sub>r (&level + \<guillemotleft>real_of_pos t\<guillemotright>) \<triangleleft> &valve \<triangleright>\<^sub>R level :=\<^sub>r (&level - \<guillemotleft>real_of_pos t\<guillemotright>)))"
  by (simp add: hyrel2trl_cond hyrel2trel_hEvolves tank_ode_1_evolve tank_ode_2_evolve closure continuous_intros, rel_auto)

(* The difference between the sensed value of the water level and the actual level is less than 0.1 *)

(*
lemma wt_prop1:
  "\<lbrace>true\<rbrace>FMI Init [FMU[ctr, Ctr 0 10], FMU[tank, Tank]] (FixedStep 0.001) Wiring \<lbrace>&tank:level - &ctr:levelSensor <\<^sub>u 0.1\<rbrace>\<^sub>r"
proof (rule FMI_hoare_rp, simp_all)
  show "\<lbrace>true\<rbrace> [ctr:[fmiInstantiate (Ctr 0 10)]\<^sup>+ ;; tank:[fmiInstantiate Tank]\<^sup>+]\<^sub>S ;; \<langle>Init\<rangle>\<^sub>r \<lbrace>&tank:level - &ctr:levelSensor <\<^sub>u 0.1\<rbrace>\<^sub>r"
    by (simp add: Ctr_def Step_VDMRT Tank_def Init_def rpred frame alpha usubst closure, rel_auto)
  show "\<lbrace>&tank:level - &ctr:levelSensor <\<^sub>u 0.1\<rbrace>
          \<langle>Wiring\<rangle>\<^sub>r ;; Step_FMUs [FMU[ctr, Ctr 0 10], FMU[tank, Tank]] (FixedStep (1 / 1000))
        \<lbrace>&tank:level - &ctr:levelSensor <\<^sub>u 0.1\<rbrace>\<^sub>r"
    apply (simp add: Wiring_def rpred frame closure usubst Ctr_def Tank_def Step_FMUs_def Step_VDMRT Step_Modelica_FMU HyStep_cond tank_ode_1_evolve tank_ode_2_evolve)
    apply (simp add: HyStep_hEvolves' closure continuous_intros usubst alpha)
    apply (uexpr_simp simps:pos_transfer)
    apply (rel_auto)
    apply (simp_all add: pos_transfer)
  done
qed
*)

abbreviation WTI :: "wt_st upred" where
  "WTI \<equiv> &ctr:ctdown =\<^sub>u 0.001 \<and>
         ((&tank:level <\<^sub>u 9.9) \<or>
          (&tank:level \<ge>\<^sub>u 9.9 \<and> &tank:level <\<^sub>u 9.95 \<and> \<not> &ctr:valveOn) \<or>
          (&tank:level \<ge>\<^sub>u 9.9 \<and> &tank:level <\<^sub>u 10 \<and> &ctr:valveOn))"

lemma wt_lemma_1:
  "\<lbrace>true\<rbrace> WaterTank 0 10 \<lbrace>WTI\<rbrace>\<^sub>r"
  unfolding WaterTank_def
  by (fmi_hoare defs: Tank_def Ctr_def Init_def Wiring_def tank_ode_1_evolve tank_ode_2_evolve)

lemma wt_safe:
  "\<lbrace>true\<rbrace> WaterTank 0 10 \<lbrace>&tank:level <\<^sub>u 10\<rbrace>\<^sub>r"
  by (rule hoare_rp_strengthen[where q'="WTI"])
     (rel_auto, rule wt_lemma_1)

end


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

section \<open>Kleene Algebras\<close>

text \<open>
Kleene algebras have been axiomatised by Kozen to describe the equational theory of regular languages \cite{Kozen1994}.
Binary relations are another important model.
This theory implements variants of Kleene algebras based on idempotent left semirings \cite{Moeller2007}.
The weakening of some semiring axioms allows the treatment of further computation models.
The presented algebras are special cases of iterings, so many results can be inherited.
\<close>

theory Kleene_Algebras

imports Iterings

begin

text \<open>
We start with left Kleene algebras, which use the left unfold and left induction axioms of Kleene algebras.
\<close>

class star =
  fixes star :: "'a \<Rightarrow> 'a" ("_\<^sup>\<star>" [100] 100)

class left_kleene_algebra = idempotent_left_semiring + star +
  assumes star_left_unfold : "1 \<squnion> y * y\<^sup>\<star> \<le> y\<^sup>\<star>"
  assumes star_left_induct : "z \<squnion> y * x \<le> x \<longrightarrow> y\<^sup>\<star> * z \<le> x"
begin

no_notation
  trancl ("(_\<^sup>+)" [1000] 999)

abbreviation tc ("_\<^sup>+" [100] 100) where "tc x \<equiv> x * x\<^sup>\<star>"

lemma star_left_unfold_equal:
  "1 \<squnion> x * x\<^sup>\<star> = x\<^sup>\<star>"
  by (metis sup_right_isotone antisym mult_right_isotone mult_1_right star_left_induct star_left_unfold)

text \<open>
This means that for some properties of Kleene algebras, only one inequality can be derived, as exemplified by the following sliding rule.
\<close>

lemma star_left_slide:
  "(x * y)\<^sup>\<star> * x \<le> x * (y * x)\<^sup>\<star>"
  by (metis mult_assoc mult_left_sub_dist_sup mult_1_right star_left_induct star_left_unfold_equal)

lemma star_isotone:
  "x \<le> y \<Longrightarrow> x\<^sup>\<star> \<le> y\<^sup>\<star>"
  by (metis sup_right_isotone mult_left_isotone order_trans star_left_unfold mult_1_right star_left_induct)

lemma star_sup_1:
  "(x \<squnion> y)\<^sup>\<star> = x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star>"
proof (rule antisym)
  have "y * x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star> \<le> (y * x\<^sup>\<star>)\<^sup>\<star>"
    using sup_right_divisibility star_left_unfold_equal by auto
  also have "... \<le> x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star>"
    using mult_left_isotone sup_left_divisibility star_left_unfold_equal by fastforce
  finally have "(x \<squnion> y) * (x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star>) \<le> x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star>"
    by (metis le_supI mult_right_dist_sup mult_right_sub_dist_sup_right mult_assoc star_left_unfold_equal)
  hence "1 \<squnion> (x \<squnion> y) * (x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star>) \<le> x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star>"
    using reflexive_mult_closed star_left_unfold by auto
  thus "(x \<squnion> y)\<^sup>\<star> \<le> x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star>"
    using star_left_induct by force
next
  have "x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star> \<le> x\<^sup>\<star> * (y * (x \<squnion> y)\<^sup>\<star>)\<^sup>\<star>"
    by (simp add: mult_right_isotone star_isotone)
  also have "... \<le> x\<^sup>\<star> * ((x \<squnion> y) * (x \<squnion> y)\<^sup>\<star>)\<^sup>\<star>"
    by (simp add: mult_right_isotone mult_right_sub_dist_sup_right star_isotone)
  also have "... \<le> x\<^sup>\<star> * (x \<squnion> y)\<^sup>\<star>\<^sup>\<star>"
    using mult_right_isotone star_left_unfold star_isotone by auto
  also have "... \<le> (x \<squnion> y)\<^sup>\<star> * (x \<squnion> y)\<^sup>\<star>\<^sup>\<star>"
    by (simp add: mult_left_isotone star_isotone)
  also have "... \<le> (x \<squnion> y)\<^sup>\<star>"
    by (metis sup.bounded_iff mult_1_right star_left_induct star_left_unfold)
  finally show "x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star> \<le> (x \<squnion> y)\<^sup>\<star>"
    by simp
qed

end

text \<open>
We now show that left Kleene algebras form iterings.
A sublocale is used instead of a subclass, because iterings use a different iteration operation.
\<close>

sublocale left_kleene_algebra < star: left_conway_semiring where circ = star
  apply unfold_locales
  apply (rule star_left_unfold_equal)
  apply (rule star_left_slide)
  by (rule star_sup_1)

context left_kleene_algebra
begin

text \<open>
A number of lemmas in this class are taken from Georg Struth's Kleene algebra theory \cite{ArmstrongGomesStruthWeber2016}.
\<close>

lemma star_sub_one:
  "x \<le> 1 \<Longrightarrow> x\<^sup>\<star> = 1"
  by (metis sup_right_isotone eq_iff le_iff_sup mult_1_right star.circ_plus_one star_left_induct)

lemma star_one:
  "1\<^sup>\<star> = 1"
  by (simp add: star_sub_one)

lemma star_left_induct_mult:
  "x * y \<le> y \<Longrightarrow> x\<^sup>\<star> * y \<le> y"
  by (simp add: star_left_induct)

lemma star_left_induct_mult_iff:
  "x * y \<le> y \<longleftrightarrow> x\<^sup>\<star> * y \<le> y"
  using mult_left_isotone order_trans star.circ_increasing star_left_induct_mult by blast

lemma star_involutive:
  "x\<^sup>\<star> = x\<^sup>\<star>\<^sup>\<star>"
  using star.circ_circ_sup star_sup_1 star_one by auto

lemma star_sup_one:
  "(1 \<squnion> x)\<^sup>\<star> = x\<^sup>\<star>"
  using star.circ_circ_sup star_involutive by auto

lemma star_left_induct_equal:
  "z \<squnion> x * y = y \<Longrightarrow> x\<^sup>\<star> * z \<le> y"
  by (simp add: star_left_induct)

lemma star_left_induct_mult_equal:
  "x * y = y \<Longrightarrow> x\<^sup>\<star> * y \<le> y"
  by (simp add: star_left_induct_mult)

lemma star_star_upper_bound:
  "x\<^sup>\<star> \<le> z\<^sup>\<star> \<Longrightarrow> x\<^sup>\<star>\<^sup>\<star> \<le> z\<^sup>\<star>"
  using star_involutive by auto

lemma star_simulation_left:
  assumes "x * z \<le> z * y"
    shows "x\<^sup>\<star> * z \<le> z * y\<^sup>\<star>"
proof -
  have "x * z * y\<^sup>\<star> \<le> z * y * y\<^sup>\<star>"
    by (simp add: assms mult_left_isotone)
  also have "... \<le> z * y\<^sup>\<star>"
    by (simp add: mult_right_isotone star.left_plus_below_circ mult_assoc)
  finally have "z \<squnion> x * z * y\<^sup>\<star> \<le> z * y\<^sup>\<star>"
    using star.circ_back_loop_prefixpoint by auto
  thus ?thesis
    by (simp add: star_left_induct mult_assoc)
qed

lemma quasicomm_1:
  "y * x \<le> x * (x \<squnion> y)\<^sup>\<star> \<longleftrightarrow> y\<^sup>\<star> * x \<le> x * (x \<squnion> y)\<^sup>\<star>"
  by (metis mult_isotone order_refl order_trans star.circ_increasing star_involutive star_simulation_left)

lemma star_rtc_3:
  "1 \<squnion> x \<squnion> y * y = y \<Longrightarrow> x\<^sup>\<star> \<le> y"
  by (metis sup.bounded_iff le_iff_sup mult_left_sub_dist_sup_left mult_1_right star_left_induct_mult_iff star.circ_sub_dist)

lemma star_decompose_1:
  "(x \<squnion> y)\<^sup>\<star> = (x\<^sup>\<star> * y\<^sup>\<star>)\<^sup>\<star>"
  apply (rule antisym)
  apply (simp add: star.circ_sup_2)
  using star.circ_sub_dist_3 star_isotone star_involutive by fastforce

lemma star_sum:
  "(x \<squnion> y)\<^sup>\<star> = (x\<^sup>\<star> \<squnion> y\<^sup>\<star>)\<^sup>\<star>"
  using star_decompose_1 star_involutive by auto

lemma star_decompose_3:
  "(x\<^sup>\<star> * y\<^sup>\<star>)\<^sup>\<star> = x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star>"
  using star_sup_1 star_decompose_1 by auto

text \<open>
In contrast to iterings, we now obtain that the iteration operation results in least fixpoints.
\<close>

lemma star_loop_least_fixpoint:
  "y * x \<squnion> z = x \<Longrightarrow> y\<^sup>\<star> * z \<le> x"
  by (simp add: sup_commute star_left_induct_equal)

lemma star_loop_is_least_fixpoint:
  "is_least_fixpoint (\<lambda>x . y * x \<squnion> z) (y\<^sup>\<star> * z)"
  by (simp add: is_least_fixpoint_def star.circ_loop_fixpoint star_loop_least_fixpoint)

lemma star_loop_mu:
  "\<mu> (\<lambda>x . y * x \<squnion> z) = y\<^sup>\<star> * z"
  by (metis least_fixpoint_same star_loop_is_least_fixpoint)

lemma affine_has_least_fixpoint:
  "has_least_fixpoint (\<lambda>x . y * x \<squnion> z)"
  by (metis has_least_fixpoint_def star_loop_is_least_fixpoint)

lemma star_outer_increasing:
  "x \<le> y\<^sup>\<star> * x * y\<^sup>\<star>"
  by (metis star.circ_back_loop_prefixpoint star.circ_loop_fixpoint sup.boundedE)

(*
lemma circ_sup: "(x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<star> = (x \<squnion> y)\<^sup>\<star>" nitpick [expect=genuine,card=7] oops
lemma circ_mult: "1 \<squnion> x * (y * x)\<^sup>\<star> * y = (x * y)\<^sup>\<star>" nitpick [expect=genuine] oops
lemma circ_plus_same: "x\<^sup>\<star> * x = x * x\<^sup>\<star>" nitpick [expect=genuine] oops
lemma circ_unfold_sum: "(x \<squnion> y)\<^sup>\<star> = x\<^sup>\<star> \<squnion> x\<^sup>\<star> * y * (x \<squnion> y)\<^sup>\<star>" nitpick [expect=genuine,card=7] oops
lemma mult_zero_sup_circ_2: "(x \<squnion> y * bot)\<^sup>\<star> = x\<^sup>\<star> \<squnion> x\<^sup>\<star> * y * bot" nitpick [expect=genuine,card=7] oops
lemma circ_simulate_left: "x * z \<le> z * y \<squnion> w \<longrightarrow> x\<^sup>\<star> * z \<le> (z \<squnion> x\<^sup>\<star> * w) * y\<^sup>\<star>" nitpick [expect=genuine] oops
lemma circ_simulate_1: "y * x \<le> x * y \<longrightarrow> y\<^sup>\<star> * x\<^sup>\<star> \<le> x\<^sup>\<star> * y\<^sup>\<star>" nitpick [expect=genuine,card=7] oops
lemma circ_separate_1: "y * x \<le> x * y \<longrightarrow> (x \<squnion> y)\<^sup>\<star> = x\<^sup>\<star> * y\<^sup>\<star>" nitpick [expect=genuine,card=7] oops
lemma atomicity_refinement: "s = s * q \<and> x = q * x \<and> q * b = bot \<and> r * b \<le> b * r \<and> r * l \<le> l * r \<and> x * l \<le> l * x \<and> b * l \<le> l * b \<and> q * l \<le> l * q \<and> r\<^sup>\<star> * q \<le> q * r\<^sup>\<star> \<and> q \<le> 1 \<longrightarrow> s * (x \<squnion> b \<squnion> r \<squnion> l)\<^sup>\<star> * q \<le> s * (x * b\<^sup>\<star> * q \<squnion> r \<squnion> l)\<^sup>\<star>" nitpick [expect=genuine] oops
lemma circ_simulate_left_plus: "x * z \<le> z * y\<^sup>\<star> \<squnion> w \<longrightarrow> x\<^sup>\<star> * z \<le> (z \<squnion> x\<^sup>\<star> * w) * y\<^sup>\<star>" nitpick [expect=genuine] oops
lemma circ_separate_unfold: "(y * x\<^sup>\<star>)\<^sup>\<star> = y\<^sup>\<star> \<squnion> y\<^sup>\<star> * y * x * x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star>" nitpick [expect=genuine] oops
lemma separation: "y * x \<le> x * y\<^sup>\<star> \<longrightarrow> (x \<squnion> y)\<^sup>\<star> = x\<^sup>\<star> * y\<^sup>\<star>" nitpick [expect=genuine,card=7] oops
lemma circ_simulate_4: "y * x \<le> x * x\<^sup>\<star> * (1 \<squnion> y) \<longrightarrow> y\<^sup>\<star> * x\<^sup>\<star> \<le> x\<^sup>\<star> * y\<^sup>\<star>" nitpick [expect=genuine,card=7] oops
lemma circ_simulate_5: "y * x \<le> x * x\<^sup>\<star> * (x \<squnion> y) \<longrightarrow> y\<^sup>\<star> * x\<^sup>\<star> \<le> x\<^sup>\<star> * y\<^sup>\<star>" nitpick [expect=genuine,card=7] oops
lemma circ_simulate_6: "y * x \<le> x * (x \<squnion> y) \<longrightarrow> y\<^sup>\<star> * x\<^sup>\<star> \<le> x\<^sup>\<star> * y\<^sup>\<star>" nitpick [expect=genuine,card=7] oops
lemma circ_separate_4: "y * x \<le> x * x\<^sup>\<star> * (1 \<squnion> y) \<longrightarrow> (x \<squnion> y)\<^sup>\<star> = x\<^sup>\<star> * y\<^sup>\<star>" nitpick [expect=genuine,card=7] oops
lemma circ_separate_5: "y * x \<le> x * x\<^sup>\<star> * (x \<squnion> y) \<longrightarrow> (x \<squnion> y)\<^sup>\<star> = x\<^sup>\<star> * y\<^sup>\<star>" nitpick [expect=genuine,card=7] oops
lemma circ_separate_6: "y * x \<le> x * (x \<squnion> y) \<longrightarrow> (x \<squnion> y)\<^sup>\<star> = x\<^sup>\<star> * y\<^sup>\<star>" nitpick [expect=genuine,card=7] oops
*)

end

text \<open>
We next add the right induction rule, which allows us to strengthen many inequalities of left Kleene algebras to equalities.
\<close>

class strong_left_kleene_algebra = left_kleene_algebra +
  assumes star_right_induct: "z \<squnion> x * y \<le> x \<longrightarrow> z * y\<^sup>\<star> \<le> x"
begin

lemma star_plus:
  "y\<^sup>\<star> * y = y * y\<^sup>\<star>"
proof (rule antisym)
  show "y\<^sup>\<star> * y \<le> y * y\<^sup>\<star>"
    by (simp add: star.circ_plus_sub)
next
  have "y\<^sup>\<star> * y * y \<le> y\<^sup>\<star> * y"
    by (simp add: mult_left_isotone star.right_plus_below_circ)
  hence "y \<squnion> y\<^sup>\<star> * y * y \<le> y\<^sup>\<star> * y"
    by (simp add: star.circ_mult_increasing_2)
  thus "y * y\<^sup>\<star> \<le> y\<^sup>\<star> * y"
    using star_right_induct by blast
qed

lemma star_slide:
  "(x * y)\<^sup>\<star> * x = x * (y * x)\<^sup>\<star>"
proof (rule antisym)
  show "(x * y)\<^sup>\<star> * x \<le> x * (y * x)\<^sup>\<star>"
    by (rule star_left_slide)
next
  have "x \<squnion> (x * y)\<^sup>\<star> * x * y * x \<le> (x * y)\<^sup>\<star> * x"
    by (metis (full_types) sup.commute eq_refl star.circ_loop_fixpoint mult.assoc star_plus)
  thus "x * (y * x)\<^sup>\<star> \<le> (x * y)\<^sup>\<star> * x"
    by (simp add: mult_assoc star_right_induct)
qed

lemma star_simulation_right:
  assumes "z * x \<le> y * z"
    shows "z * x\<^sup>\<star> \<le> y\<^sup>\<star> * z"
proof -
  have "y\<^sup>\<star> * z * x \<le> y\<^sup>\<star> * z"
    by (metis assms dual_order.trans mult_isotone mult_left_sub_dist_sup_right star.circ_loop_fixpoint star.circ_transitive_equal sup.cobounded1 mult_assoc)
  thus ?thesis
    by (metis le_supI star.circ_loop_fixpoint star_right_induct sup.cobounded2)
qed

end

text \<open>
Again we inherit results from the itering hierarchy.
\<close>

sublocale strong_left_kleene_algebra < star: itering_1 where circ = star
  apply unfold_locales
  apply (simp add: star_slide)
  by (simp add: star_simulation_right)

context strong_left_kleene_algebra
begin

lemma star_right_induct_mult:
  "y * x \<le> y \<Longrightarrow> y * x\<^sup>\<star> \<le> y"
  by (simp add: star_right_induct)

lemma star_right_induct_mult_iff:
  "y * x \<le> y \<longleftrightarrow> y * x\<^sup>\<star> \<le> y"
  using mult_right_isotone order_trans star.circ_increasing star_right_induct_mult by blast

lemma star_simulation_right_equal:
  "z * x = y * z \<Longrightarrow> z * x\<^sup>\<star> = y\<^sup>\<star> * z"
  by (metis eq_iff star_simulation_left star_simulation_right)

lemma star_simulation_star:
  "x * y \<le> y * x \<Longrightarrow> x\<^sup>\<star> * y\<^sup>\<star> \<le> y\<^sup>\<star> * x\<^sup>\<star>"
  by (simp add: star_simulation_left star_simulation_right)

lemma star_right_induct_equal:
  "z \<squnion> y * x = y \<Longrightarrow> z * x\<^sup>\<star> \<le> y"
  by (simp add: star_right_induct)

lemma star_right_induct_mult_equal:
  "y * x = y \<Longrightarrow> y * x\<^sup>\<star> \<le> y"
  by (simp add: star_right_induct_mult)

lemma star_back_loop_least_fixpoint:
  "x * y \<squnion> z = x \<Longrightarrow> z * y\<^sup>\<star> \<le> x"
  by (simp add: sup_commute star_right_induct_equal)

lemma star_back_loop_is_least_fixpoint:
  "is_least_fixpoint (\<lambda>x . x * y \<squnion> z) (z * y\<^sup>\<star>)"
proof (unfold is_least_fixpoint_def, rule conjI)
  have "(z * y\<^sup>\<star> * y \<squnion> z) * y \<le> z * y\<^sup>\<star> * y \<squnion> z"
    using le_supI1 mult_left_isotone star.circ_back_loop_prefixpoint by auto
  hence "z * y\<^sup>\<star> \<le> z * y\<^sup>\<star> * y \<squnion> z"
    by (simp add: star_right_induct)
  thus "z * y\<^sup>\<star> * y \<squnion> z = z * y\<^sup>\<star>"
    using antisym star.circ_back_loop_prefixpoint by auto
next
  show "\<forall>x. x * y \<squnion> z = x \<longrightarrow> z * y\<^sup>\<star> \<le> x"
    by (simp add: star_back_loop_least_fixpoint)
qed

lemma star_square:
  "x\<^sup>\<star> = (1 \<squnion> x) * (x * x)\<^sup>\<star>"
proof -
  let ?f = "\<lambda>y . y * x \<squnion> 1"
  have 1: "isotone ?f"
    by (metis sup_left_isotone isotone_def mult_left_isotone)
  have "?f \<circ> ?f = (\<lambda>y . y * (x * x) \<squnion> (1 \<squnion> x))"
    by (simp add: sup_assoc sup_commute mult_assoc mult_right_dist_sup o_def)
  thus ?thesis
    using 1 by (metis mu_square mult_left_one star_back_loop_mu has_least_fixpoint_def star_back_loop_is_least_fixpoint)
qed

lemma star_square_2:
  "x\<^sup>\<star> = (x * x)\<^sup>\<star> * (x \<squnion> 1)"
proof -
  have "(1 \<squnion> x) * (x * x)\<^sup>\<star> = (x * x)\<^sup>\<star> * 1 \<squnion> x * (x * x)\<^sup>\<star>"
    using mult_right_dist_sup by force
  thus ?thesis
    by (metis (no_types) antisym mult_left_sub_dist_sup star.circ_square_2 star_slide sup_commute star_square)
qed

lemma star_circ_simulate_right_plus:
  assumes "z * x \<le> y * y\<^sup>\<star> * z \<squnion> w"
    shows "z * x\<^sup>\<star> \<le> y\<^sup>\<star> * (z \<squnion> w * x\<^sup>\<star>)"
proof -
  have "(z \<squnion> w * x\<^sup>\<star>) * x \<le> z * x \<squnion> w * x\<^sup>\<star>"
    using mult_right_dist_sup star.circ_back_loop_prefixpoint sup_right_isotone by auto
  also have "... \<le> y * y\<^sup>\<star> * z \<squnion> w \<squnion> w * x\<^sup>\<star>"
    using assms sup_left_isotone by blast
  also have "... \<le> y * y\<^sup>\<star> * z \<squnion> w * x\<^sup>\<star>"
    using le_supI1 star.circ_back_loop_prefixpoint sup_commute by auto
  also have "... \<le> y\<^sup>\<star> * (z \<squnion> w * x\<^sup>\<star>)"
    by (metis sup.bounded_iff mult_isotone mult_left_isotone mult_left_one mult_left_sub_dist_sup_left star.circ_reflexive star.left_plus_below_circ)
  finally have "y\<^sup>\<star> * (z \<squnion> w * x\<^sup>\<star>) * x \<le> y\<^sup>\<star> * (z \<squnion> w * x\<^sup>\<star>)"
    by (metis mult_assoc mult_right_isotone star.circ_transitive_equal)
  thus ?thesis
    by (metis sup.bounded_iff star_right_induct mult_left_sub_dist_sup_left star.circ_loop_fixpoint)
qed

lemma transitive_star:
  "x * x \<le> x \<Longrightarrow> x\<^sup>\<star> = 1 \<squnion> x"
  by (metis order.antisym star.circ_mult_increasing_2 star.circ_plus_same star_left_induct_mult star_left_unfold_equal)

(*
lemma star_circ_simulate_left_plus: "x * z \<le> z * y\<^sup>\<star> \<squnion> w \<longrightarrow> x\<^sup>\<star> * z \<le> (z \<squnion> x\<^sup>\<star> * w) * y\<^sup>\<star>" nitpick [expect=genuine,card=7] oops
*)

end

text \<open>
The following class contains a generalisation of Kleene algebras, which lacks the right zero axiom.
\<close>

class left_zero_kleene_algebra = idempotent_left_zero_semiring + strong_left_kleene_algebra
begin

lemma star_star_absorb:
  "y\<^sup>\<star> * (y\<^sup>\<star> * x)\<^sup>\<star> * y\<^sup>\<star> = (y\<^sup>\<star> * x)\<^sup>\<star> * y\<^sup>\<star>"
  by (metis star.circ_transitive_equal star_slide mult_assoc)

lemma star_circ_simulate_left_plus:
  assumes "x * z \<le> z * y\<^sup>\<star> \<squnion> w"
    shows "x\<^sup>\<star> * z \<le> (z \<squnion> x\<^sup>\<star> * w) * y\<^sup>\<star>"
proof -
  have "x * (x\<^sup>\<star> * (w * y\<^sup>\<star>)) \<le> x\<^sup>\<star> * (w * y\<^sup>\<star>)"
    by (metis (no_types) mult_right_sub_dist_sup_left star.circ_loop_fixpoint mult_assoc)
  hence "x * ((z \<squnion> x\<^sup>\<star> * w) * y\<^sup>\<star>) \<le> x * z * y\<^sup>\<star> \<squnion> x\<^sup>\<star> * w * y\<^sup>\<star>"
    using mult_left_dist_sup mult_right_dist_sup sup_right_isotone mult_assoc by presburger
  also have "... \<le> (z * y\<^sup>\<star> \<squnion> w) * y\<^sup>\<star> \<squnion> x\<^sup>\<star> * w * y\<^sup>\<star>"
    using assms mult_isotone semiring.add_right_mono by blast
  also have "... = z * y\<^sup>\<star> \<squnion> w * y\<^sup>\<star> \<squnion> x\<^sup>\<star> * w * y\<^sup>\<star>"
    by (simp add: mult_right_dist_sup star.circ_transitive_equal mult_assoc)
  also have "... = (z \<squnion> w \<squnion> x\<^sup>\<star> * w) * y\<^sup>\<star>"
    by (simp add: mult_right_dist_sup)
  also have "... = (z \<squnion> x\<^sup>\<star> * w) * y\<^sup>\<star>"
    by (metis sup_assoc sup_ge2 le_iff_sup star.circ_loop_fixpoint)
  finally show ?thesis
    by (metis sup.bounded_iff mult_left_sub_dist_sup_left mult_1_right star.circ_right_unfold_1 star_left_induct)
qed

lemma star_one_sup_below:
  "x * y\<^sup>\<star> * (1 \<squnion> z) \<le> x * (y \<squnion> z)\<^sup>\<star>"
proof -
  have "y\<^sup>\<star> * z \<le> (y \<squnion> z)\<^sup>\<star>"
    using sup_ge2 order_trans star.circ_increasing star.circ_mult_upper_bound star.circ_sub_dist by blast
  hence "y\<^sup>\<star> \<squnion> y\<^sup>\<star> * z \<le> (y \<squnion> z)\<^sup>\<star>"
    by (simp add: star.circ_sup_upper_bound star.circ_sub_dist)
  hence "y\<^sup>\<star> * (1 \<squnion> z) \<le> (y \<squnion> z)\<^sup>\<star>"
    by (simp add: mult_left_dist_sup)
  thus ?thesis
    by (metis mult_right_isotone mult_assoc)
qed

text \<open>
The following theorem is similar to the puzzle where persons insert themselves always in the middle between two groups of people in a line.
Here, however, items in the middle annihilate each other, leaving just one group of items behind.
\<close>

lemma cancel_separate:
  assumes "x * y \<le> 1"
    shows "x\<^sup>\<star> * y\<^sup>\<star> \<le> x\<^sup>\<star> \<squnion> y\<^sup>\<star>"
proof -
  have "x * y\<^sup>\<star> = x \<squnion> x * y * y\<^sup>\<star>"
    by (metis mult_assoc mult_left_dist_sup mult_1_right star_left_unfold_equal)
  also have "... \<le> x \<squnion> y\<^sup>\<star>"
    by (meson assms dual_order.trans order.refl star.circ_mult_upper_bound star.circ_reflexive sup_right_isotone)
  also have "... \<le> x\<^sup>\<star> \<squnion> y\<^sup>\<star>"
    using star.circ_increasing sup_left_isotone by auto
  finally have 1: "x * y\<^sup>\<star> \<le> x\<^sup>\<star> \<squnion> y\<^sup>\<star>"
    .
  have "x * (x\<^sup>\<star> \<squnion> y\<^sup>\<star>) = x * x\<^sup>\<star> \<squnion> x * y\<^sup>\<star>"
    by (simp add: mult_left_dist_sup)
  also have "... \<le> x\<^sup>\<star> \<squnion> y\<^sup>\<star>"
    using 1 by (metis sup.bounded_iff sup_ge1 order_trans star.left_plus_below_circ)
  finally have 2: "x * (x\<^sup>\<star> \<squnion> y\<^sup>\<star>) \<le> x\<^sup>\<star> \<squnion> y\<^sup>\<star>"
    .
  have "y\<^sup>\<star> \<le> x\<^sup>\<star> \<squnion> y\<^sup>\<star>"
    by simp
  hence "y\<^sup>\<star> \<squnion> x * (x\<^sup>\<star> \<squnion> y\<^sup>\<star>) \<le> x\<^sup>\<star> \<squnion> y\<^sup>\<star>"
    using 2 sup.bounded_iff by blast
  thus ?thesis
    by (metis star_left_induct)
qed

lemma star_separate:
  assumes "x * y = bot"
      and "y * y = bot"
    shows "(x \<squnion> y)\<^sup>\<star> = x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>"
proof -
  have 1: "y\<^sup>\<star> = 1 \<squnion> y"
    using assms(2) by (simp add: transitive_star)
  have "(x \<squnion> y)\<^sup>\<star> = y\<^sup>\<star> * (x * y\<^sup>\<star>)\<^sup>\<star>"
    by (simp add: star.circ_decompose_6 star_sup_1)
  also have "... = y\<^sup>\<star> * (x * (1 \<squnion> y * y\<^sup>\<star>))\<^sup>\<star>"
    by (simp add: star_left_unfold_equal)
  also have "... = (1 \<squnion> y) * x\<^sup>\<star>"
    using 1 by (simp add: assms mult_left_dist_sup)
  also have "... = x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>"
    by (simp add: mult_right_dist_sup)
  finally show ?thesis
    .
qed

end

text \<open>
We can now inherit from the strongest variant of iterings.
\<close>

sublocale left_zero_kleene_algebra < star: itering where circ = star
  apply unfold_locales
  apply (metis star.circ_sup_9)
  apply (metis star.circ_mult_1)
  apply (simp add: star_circ_simulate_right_plus)
  by (simp add: star_circ_simulate_left_plus)

context left_zero_kleene_algebra
begin

lemma star_absorb:
  "x * y = bot \<Longrightarrow> x * y\<^sup>\<star> = x"
  by (metis sup.bounded_iff antisym_conv star.circ_back_loop_prefixpoint star.circ_elimination)

lemma star_separate_2:
  assumes "x * z\<^sup>+ * y = bot"
      and "y * z\<^sup>+ * y = bot"
      and "z * x = bot"
    shows "(x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * (z * (1 \<squnion> y * x\<^sup>\<star>))\<^sup>\<star> = z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>\<star>"
proof -
  have 1: "x\<^sup>\<star> * z\<^sup>+ * y = z\<^sup>+ * y"
    by (metis assms mult_assoc mult_1_left mult_left_zero star.circ_zero star_simulation_right_equal)
  have 2: "z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>+ \<le> z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>\<star>"
    by (simp add: mult_right_isotone star.left_plus_below_circ)
  have "z\<^sup>\<star> * z\<^sup>+ * y * x\<^sup>\<star> \<le> z\<^sup>\<star> * y * x\<^sup>\<star>"
    by (metis mult_left_isotone star.left_plus_below_circ star.right_plus_circ star_plus)
  also have "... \<le> z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>)"
    by (simp add: mult_assoc mult_left_sub_dist_sup_right)
  also have "... \<le> z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>\<star>"
    using sup_right_divisibility star.circ_back_loop_fixpoint by blast
  finally have 3: "z\<^sup>\<star> * z\<^sup>+ * y * x\<^sup>\<star> \<le> z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>\<star>"
    .
  have "z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>\<star> * (z * (1 \<squnion> y * x\<^sup>\<star>)) = z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>+ \<squnion> z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>+ * y * x\<^sup>\<star>"
    by (metis mult_1_right semiring.distrib_left star.circ_plus_same mult_assoc)
  also have "... = z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>+ \<squnion> z\<^sup>\<star> * (1 \<squnion> y) * x\<^sup>\<star> * z\<^sup>+ * y * x\<^sup>\<star>"
    by (simp add: semiring.distrib_right mult_assoc)
  also have "... = z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>+ \<squnion> z\<^sup>\<star> * (1 \<squnion> y) * z\<^sup>+ * y * x\<^sup>\<star>"
    using 1 by (simp add: mult_assoc)
  also have "... = z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>+ \<squnion> z\<^sup>\<star> * z\<^sup>+ * y * x\<^sup>\<star> \<squnion> z\<^sup>\<star> * y * z\<^sup>+ * y * x\<^sup>\<star>"
    using mult_left_dist_sup mult_right_dist_sup sup_assoc by auto
  also have "... = z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>+ \<squnion> z\<^sup>\<star> * z\<^sup>+ * y * x\<^sup>\<star>"
    by (metis assms(2) mult_left_dist_sup mult_left_zero sup_commute sup_monoid.add_0_left mult_assoc)
  also have "... \<le> z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>\<star>"
    using 2 3 by simp
  finally have "(x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) \<squnion> z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>\<star> * (z * (1 \<squnion> y * x\<^sup>\<star>)) \<le> z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>\<star>"
    by (simp add: star_outer_increasing)
  hence 4: "(x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * (z * (1 \<squnion> y * x\<^sup>\<star>))\<^sup>\<star> \<le> z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>\<star>"
    by (simp add: star_right_induct)
  have 5: "(x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>\<star> \<le> (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * (z * (1 \<squnion> y * x\<^sup>\<star>))\<^sup>\<star>"
    by (metis sup_ge1 mult_right_isotone mult_1_right star_isotone)
  have "z * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) = z * x\<^sup>\<star> \<squnion> z * y * x\<^sup>\<star>"
    by (simp add: mult_assoc mult_left_dist_sup)
  also have "... = z \<squnion> z * y * x\<^sup>\<star>"
    by (simp add: assms star_absorb)
  also have "... = z * (1 \<squnion> y * x\<^sup>\<star>)"
    by (simp add: mult_assoc mult_left_dist_sup)
  also have "... \<le> (z * (1 \<squnion> y * x\<^sup>\<star>))\<^sup>\<star>"
    by (simp add: star.circ_increasing)
  also have "... \<le> (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * (z * (1 \<squnion> y * x\<^sup>\<star>))\<^sup>\<star>"
    by (metis le_supE mult_right_sub_dist_sup_left star.circ_loop_fixpoint)
  finally have "z * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) \<le> (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * (z * (1 \<squnion> y * x\<^sup>\<star>))\<^sup>\<star>"
    .
  hence "z * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * (z * (1 \<squnion> y * x\<^sup>\<star>))\<^sup>\<star> \<le> (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * (z * (1 \<squnion> y * x\<^sup>\<star>))\<^sup>\<star>"
    by (metis mult_assoc mult_left_isotone star.circ_transitive_equal)
  hence "z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>\<star> \<le> (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * (z * (1 \<squnion> y * x\<^sup>\<star>))\<^sup>\<star>"
    using 5 by (metis star_left_induct sup.bounded_iff mult_assoc)
  thus ?thesis
    using 4 by (simp add: antisym)
qed

lemma cancel_separate_eq:
  "x * y \<le> 1 \<Longrightarrow> x\<^sup>\<star> * y\<^sup>\<star> = x\<^sup>\<star> \<squnion> y\<^sup>\<star>"
  by (metis antisym cancel_separate star.circ_plus_one star.circ_sup_sub_sup_one_1 star_involutive)

lemma cancel_separate_1:
  assumes "x * y \<le> 1"
    shows "(x \<squnion> y)\<^sup>\<star> = y\<^sup>\<star> * x\<^sup>\<star>"
proof -
  have "y\<^sup>\<star> * x\<^sup>\<star> * y = y\<^sup>\<star> * x\<^sup>\<star> * x * y \<squnion> y\<^sup>\<star> * y"
    by (metis mult_right_dist_sup star.circ_back_loop_fixpoint)
  also have "... \<le> y\<^sup>\<star> * x\<^sup>\<star> \<squnion> y\<^sup>\<star> * y"
    by (metis assms semiring.add_right_mono mult_right_isotone mult_1_right mult_assoc)
  also have "... \<le> y\<^sup>\<star> * x\<^sup>\<star> \<squnion> y\<^sup>\<star>"
    using semiring.add_left_mono star.right_plus_below_circ by simp
  also have "... = y\<^sup>\<star> * x\<^sup>\<star>"
    by (metis star.circ_back_loop_fixpoint sup.left_idem sup_commute)
  finally have "y\<^sup>\<star> * x\<^sup>\<star> * y \<le> y\<^sup>\<star> * x\<^sup>\<star>"
    by simp
  hence "y\<^sup>\<star> * x\<^sup>\<star> * (x \<squnion> y) \<le> y\<^sup>\<star> * x\<^sup>\<star> * x \<squnion> y\<^sup>\<star> * x\<^sup>\<star>"
    using mult_left_dist_sup order_lesseq_imp by fastforce
  also have "... = y\<^sup>\<star> * x\<^sup>\<star>"
    by (metis star.circ_back_loop_fixpoint sup.left_idem)
  finally have "(x \<squnion> y)\<^sup>\<star> \<le> y\<^sup>\<star> * x\<^sup>\<star>"
    by (metis star.circ_decompose_7 star_right_induct_mult sup_commute)
  thus ?thesis
    using antisym star.circ_sub_dist_3 sup_commute by fastforce
qed

lemma plus_sup:
  "(x \<squnion> y)\<^sup>+ = (x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>+ \<squnion> (x\<^sup>\<star> * y)\<^sup>+"
  by (metis semiring.distrib_left star.circ_sup_9 star_plus mult_assoc)

lemma plus_half_bot:
  "x * y * x = bot \<Longrightarrow> (x * y)\<^sup>+ = x * y"
  by (metis star_absorb star_slide mult_assoc)

lemma cancel_separate_1_sup:
  assumes "x * y \<le> 1"
      and "y * x \<le> 1"
  shows "(x \<squnion> y)\<^sup>\<star> = x\<^sup>\<star> \<squnion> y\<^sup>\<star>"
  by (simp add: assms cancel_separate_1 cancel_separate_eq sup_commute)

lemma star_separate_3:
  assumes "y * x\<^sup>\<star> * y \<le> y"
    shows "(x \<squnion> y)\<^sup>\<star> = x\<^sup>\<star> \<squnion> x\<^sup>\<star> * y * x\<^sup>\<star>"
proof (rule antisym)
  have "x\<^sup>\<star> * y * (x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<star> \<le> x\<^sup>\<star> * y * x\<^sup>\<star>"
    by (metis assms mult_left_isotone mult_right_isotone star_right_induct_mult mult_assoc)
  thus "(x \<squnion> y)\<^sup>\<star> \<le> x\<^sup>\<star> \<squnion> x\<^sup>\<star> * y * x\<^sup>\<star>"
    by (metis antisym semiring.add_left_mono star.circ_sup_2 star.circ_sup_sub star.circ_unfold_sum star_decompose_3 star_slide mult_assoc)
next
  show "x\<^sup>\<star> \<squnion> x\<^sup>\<star> * y * x\<^sup>\<star> \<le> (x \<squnion> y)\<^sup>\<star>"
    using mult_isotone star.circ_increasing star.circ_sub_dist star.circ_sup_9 by auto
qed

end

text \<open>
A Kleene algebra is obtained by requiring an idempotent semiring.
\<close>

class kleene_algebra = left_zero_kleene_algebra + idempotent_semiring

text \<open>
The following classes are variants of Kleene algebras expanded by an additional iteration operation.
This is useful to study the Kleene star in computation models that do not use least fixpoints in the refinement order as the semantics of recursion.
\<close>

class left_kleene_conway_semiring = left_kleene_algebra + left_conway_semiring
begin

lemma star_zero_below_circ_mult:
  "x\<^sup>\<star> * bot \<le> x\<^sup>\<circ> * y"
  by (simp add: mult_isotone star_below_circ)

lemma star_mult_circ:
  "x\<^sup>\<star> * x\<^sup>\<circ> = x\<^sup>\<circ>"
  by (metis sup_right_divisibility antisym circ_left_unfold star_left_induct_mult star.circ_loop_fixpoint)

lemma circ_mult_star:
  "x\<^sup>\<circ> * x\<^sup>\<star> = x\<^sup>\<circ>"
  by (metis sup_assoc sup.bounded_iff circ_left_unfold circ_rtc_2 eq_iff left_plus_circ star.circ_sup_sub star.circ_back_loop_prefixpoint star.circ_increasing star_below_circ star_mult_circ star_sup_one)

lemma circ_star:
  "x\<^sup>\<circ>\<^sup>\<star> = x\<^sup>\<circ>"
  by (metis antisym circ_reflexive circ_transitive_equal star.circ_increasing star.circ_sup_one_right_unfold star_left_induct_mult_equal)

lemma star_circ:
  "x\<^sup>\<star>\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>"
  by (metis antisym circ_circ_sup circ_sub_dist le_iff_sup star.circ_rtc_2 star_below_circ)

lemma circ_sup_3:
  "(x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<star> \<le> (x \<squnion> y)\<^sup>\<circ>"
  using circ_star circ_sub_dist_3 star_isotone by fastforce

end

class left_zero_kleene_conway_semiring = left_zero_kleene_algebra + itering
begin

subclass left_kleene_conway_semiring ..

lemma circ_isolate:
  "x\<^sup>\<circ> = x\<^sup>\<circ> * bot \<squnion> x\<^sup>\<star>"
  by (metis sup_commute antisym circ_sup_upper_bound circ_mult_star circ_simulate_absorb star.left_plus_below_circ star_below_circ zero_right_mult_decreasing)

lemma circ_isolate_mult:
  "x\<^sup>\<circ> * y = x\<^sup>\<circ> * bot \<squnion> x\<^sup>\<star> * y"
  by (metis circ_isolate mult_assoc mult_left_zero mult_right_dist_sup)

lemma circ_isolate_mult_sub:
  "x\<^sup>\<circ> * y \<le> x\<^sup>\<circ> \<squnion> x\<^sup>\<star> * y"
  by (metis sup_left_isotone circ_isolate_mult zero_right_mult_decreasing)

lemma circ_sub_decompose:
  "(x\<^sup>\<circ> * y)\<^sup>\<circ> \<le> (x\<^sup>\<star> * y)\<^sup>\<circ> * x\<^sup>\<circ>"
proof -
  have "x\<^sup>\<star> * y \<squnion> x\<^sup>\<circ> * bot = x\<^sup>\<circ> * y"
    by (metis sup.commute circ_isolate_mult)
  hence "(x\<^sup>\<star> * y)\<^sup>\<circ> * x\<^sup>\<circ> = ((x\<^sup>\<circ> * y)\<^sup>\<circ> \<squnion> x\<^sup>\<circ>)\<^sup>\<star>"
    by (metis circ_star circ_sup_9 circ_sup_mult_zero star_decompose_1)
  thus ?thesis
    by (metis circ_star le_iff_sup star.circ_decompose_7 star.circ_unfold_sum)
qed

lemma circ_sup_4:
  "(x \<squnion> y)\<^sup>\<circ> = (x\<^sup>\<star> * y)\<^sup>\<circ> * x\<^sup>\<circ>"
  apply (rule antisym)
  apply (metis circ_sup circ_sub_decompose circ_transitive_equal mult_assoc mult_left_isotone)
  by (metis circ_sup circ_isotone mult_left_isotone star_below_circ)

lemma circ_sup_5:
  "(x\<^sup>\<circ> * y)\<^sup>\<circ> * x\<^sup>\<circ> = (x\<^sup>\<star> * y)\<^sup>\<circ> * x\<^sup>\<circ>"
  using circ_sup_4 circ_sup_9 by auto

lemma plus_circ:
  "(x\<^sup>\<star> * x)\<^sup>\<circ> = x\<^sup>\<circ>"
  by (metis sup_idem circ_sup_4 circ_decompose_7 circ_star star.circ_decompose_5 star.right_plus_circ)

(*
lemma "(x\<^sup>\<star> * y * x\<^sup>\<star>)\<^sup>\<circ> = (x\<^sup>\<star> * y)\<^sup>\<circ>" nitpick [expect=genuine] oops
*)

end

text \<open>
The following classes add a greatest element.
\<close>

class bounded_left_kleene_algebra = bounded_idempotent_left_semiring + left_kleene_algebra

sublocale bounded_left_kleene_algebra < star: bounded_left_conway_semiring where circ = star ..

class bounded_left_zero_kleene_algebra = bounded_idempotent_left_semiring + left_zero_kleene_algebra

sublocale bounded_left_zero_kleene_algebra < star: bounded_itering where circ = star ..

class bounded_kleene_algebra = bounded_idempotent_semiring + kleene_algebra

sublocale bounded_kleene_algebra < star: bounded_itering where circ = star ..

text \<open>
We conclude with an alternative axiomatisation of Kleene algebras.
\<close>

class kleene_algebra_var = idempotent_semiring + star +
  assumes star_left_unfold_var : "1 \<squnion> y * y\<^sup>\<star> \<le> y\<^sup>\<star>"
  assumes star_left_induct_var : "y * x \<le> x \<longrightarrow> y\<^sup>\<star> * x \<le> x"
  assumes star_right_induct_var : "x * y \<le> x \<longrightarrow> x * y\<^sup>\<star> \<le> x"
begin

subclass kleene_algebra
  apply unfold_locales
  apply (rule star_left_unfold_var)
  apply (meson sup.bounded_iff mult_right_isotone order_trans star_left_induct_var)
  by (meson sup.bounded_iff mult_left_isotone order_trans star_right_induct_var)

end

end


header {* \isaheader{Return and their corresponding call nodes} *}

theory ReturnAndCallNodes imports CFG begin

context CFG begin

subsection {* Defining @{text "return_node"} *}

definition return_node :: "'node \<Rightarrow> bool"
  where "return_node n \<equiv> \<exists>a a'. valid_edge a \<and> n = targetnode a \<and>
    valid_edge a' \<and> a \<in> get_return_edges a'"

lemma return_node_determines_call_node:
  assumes "return_node n"
  shows "\<exists>!n'. \<exists>a a'. valid_edge a \<and> n' = sourcenode a \<and> valid_edge a' \<and>
    a' \<in> get_return_edges a \<and> n = targetnode a'"
proof(rule ex_ex1I)
  from `return_node n`
  show "\<exists>n' a a'. valid_edge a \<and> n' = sourcenode a \<and> valid_edge a' \<and>
    a' \<in> get_return_edges a \<and> n = targetnode a'"
    by(simp add:return_node_def) blast
next
  fix n' nx
  assume "\<exists>a a'. valid_edge a \<and> n' = sourcenode a \<and> valid_edge a' \<and>
    a' \<in> get_return_edges a \<and> n = targetnode a'"
    and "\<exists>a a'. valid_edge a \<and> nx = sourcenode a \<and> valid_edge a' \<and>
    a' \<in> get_return_edges a \<and> n = targetnode a'"
  then obtain a a' ax ax' where "valid_edge a" and "n' = sourcenode a"
    and "valid_edge a'" and "a' \<in> get_return_edges a"
    and "n = targetnode a'" and "valid_edge ax" and "nx = sourcenode ax"
   and "valid_edge ax'" and "ax' \<in> get_return_edges ax"
    and "n = targetnode ax'"
    by blast
  from `valid_edge a` `a' \<in> get_return_edges a` have "valid_edge a'"
    by(rule get_return_edges_valid)
  from `valid_edge a` `a' \<in> get_return_edges a` obtain a''
    where intra_edge1:"valid_edge a''" "sourcenode a'' = sourcenode a"
    "targetnode a'' = targetnode a'" "kind a'' = (\<lambda>cf. False)\<^sub>\<surd>"
    by(fastforce dest:call_return_node_edge)
  from `valid_edge ax` `ax' \<in> get_return_edges ax` obtain ax''
    where intra_edge2:"valid_edge ax''" "sourcenode ax'' = sourcenode ax"
    "targetnode ax'' = targetnode ax'" "kind ax'' = (\<lambda>cf. False)\<^sub>\<surd>"
    by(fastforce dest:call_return_node_edge)
  from `valid_edge a` `a' \<in> get_return_edges a`
  obtain Q r p fs where "kind a = Q:r\<hookrightarrow>\<^bsub>p\<^esub>fs"
    by(fastforce dest!:only_call_get_return_edges)
  with `valid_edge a` `a' \<in> get_return_edges a` obtain Q' p f'
    where "kind a' = Q'\<hookleftarrow>\<^bsub>p\<^esub>f'" by(fastforce dest!:call_return_edges)
  with `valid_edge a'`
  have "\<exists>!a''. valid_edge a'' \<and> targetnode a'' = targetnode a' \<and> intra_kind(kind a'')"
    by(rule return_only_one_intra_edge)
  with intra_edge1 intra_edge2 `n = targetnode a'` `n = targetnode ax'`
  have "a'' = ax''" by(fastforce simp:intra_kind_def)
  with `sourcenode a'' = sourcenode a` `sourcenode ax'' = sourcenode ax`
    `n' = sourcenode a` `nx = sourcenode ax`
  show "n' = nx" by simp
qed

lemma return_node_THE_call_node:
  "\<lbrakk>return_node n; valid_edge a; valid_edge a'; a' \<in> get_return_edges a;
  n = targetnode a'\<rbrakk>
  \<Longrightarrow> (THE n'. \<exists>a a'. valid_edge a \<and> n' = sourcenode a \<and> valid_edge a' \<and>
  a' \<in> get_return_edges a \<and> n = targetnode a') = sourcenode a"
  by(fastforce intro!:the1_equality return_node_determines_call_node)

subsection {* Defining call nodes belonging to a certain @{text "return_node"} *}

definition call_of_return_node :: "'node \<Rightarrow> 'node \<Rightarrow> bool"
  where "call_of_return_node n n' \<equiv> \<exists>a a'. return_node n \<and>
  valid_edge a \<and> n' = sourcenode a \<and> valid_edge a' \<and>
  a' \<in> get_return_edges a \<and> n = targetnode a'"

lemma return_node_call_of_return_node:
  "return_node n \<Longrightarrow> \<exists>!n'. call_of_return_node n n'"
  by -(frule return_node_determines_call_node,unfold call_of_return_node_def,simp)

lemma call_of_return_nodes_det [dest]:
  assumes "call_of_return_node n n'" and "call_of_return_node n n''"
  shows "n' = n''"
proof -
  from `call_of_return_node n n'` have "return_node n"
    by(simp add:call_of_return_node_def)
  hence "\<exists>!n'. call_of_return_node n n'" by(rule return_node_call_of_return_node)
  with `call_of_return_node n n'` `call_of_return_node n n''`
  show ?thesis by auto
qed

lemma get_return_edges_call_of_return_nodes:
  "\<lbrakk>valid_call_list cs m; valid_return_list rs m;
    \<forall>i < length rs. rs!i \<in> get_return_edges (cs!i); length rs = length cs\<rbrakk>
  \<Longrightarrow> \<forall>i<length cs. call_of_return_node (targetnodes rs!i) (sourcenode (cs!i))"
proof(induct cs arbitrary:m rs)
  case Nil thus ?case by fastforce
next
  case (Cons c' cs')
  note IH = `\<And>m rs. \<lbrakk>valid_call_list cs' m; valid_return_list rs m;
    \<forall>i<length rs. rs ! i \<in> get_return_edges (cs' ! i); length rs = length cs'\<rbrakk>
    \<Longrightarrow> \<forall>i<length cs'. call_of_return_node (targetnodes rs ! i) (sourcenode (cs'!i))`
  from `length rs = length (c' # cs')` obtain r' rs' where "rs = r' # rs'"
    and "length rs' = length cs'" by(cases rs) auto
  with `\<forall>i<length rs. rs ! i \<in> get_return_edges ((c' # cs') ! i)`
  have "\<forall>i<length rs'. rs' ! i \<in> get_return_edges (cs' ! i)"
    and "r' \<in> get_return_edges c'" by auto
  from `valid_call_list (c'#cs') m` have "valid_edge c'"
    by(fastforce simp:valid_call_list_def)
  from this `r' \<in> get_return_edges c'`
  have "get_proc (sourcenode c') = get_proc (targetnode r')"
    by(rule get_proc_get_return_edge)
  from `valid_call_list (c'#cs') m`
  have "valid_call_list cs' (sourcenode c')"
    apply(clarsimp simp:valid_call_list_def)
    apply(hypsubst_thin)
    apply(erule_tac x="c'#cs'" in allE) apply clarsimp
    by(case_tac cs')(auto simp:sourcenodes_def)
  from `valid_return_list rs m` `rs = r' # rs'`
    `get_proc (sourcenode c') = get_proc (targetnode r')`
  have "valid_return_list rs' (sourcenode c')"
    apply(clarsimp simp:valid_return_list_def)
    apply(erule_tac x="r'#cs'" in allE) apply clarsimp
    by(case_tac cs')(auto simp:targetnodes_def)
  from IH[OF `valid_call_list cs' (sourcenode c')`
    `valid_return_list rs' (sourcenode c')`
    `\<forall>i<length rs'. rs' ! i \<in> get_return_edges (cs' ! i)` `length rs' = length cs'`]
  have all:"\<forall>i<length cs'.
    call_of_return_node (targetnodes rs' ! i) (sourcenode (cs' ! i))" .
  from `valid_edge c'` `r' \<in> get_return_edges c'` have "valid_edge r'"
    by(rule get_return_edges_valid)
  from `valid_edge r'` `valid_edge c'` `r' \<in> get_return_edges c'`
  have "return_node (targetnode r')" by(fastforce simp:return_node_def)
  with `valid_edge c'` `r' \<in> get_return_edges c'` `valid_edge r'`
  have "call_of_return_node (targetnode r') (sourcenode c')"
    by(simp add:call_of_return_node_def) blast
  with all `rs = r' # rs'` show ?case
    by auto(case_tac i,auto simp:targetnodes_def)
qed

end

end


section{*Theory Main: Everything Except AC*}

theory Main_ZF imports List_ZF IntDiv_ZF CardinalArith begin

(*The theory of "iterates" logically belongs to Nat, but can't go there because
  primrec isn't available into after Datatype.*)

subsection{* Iteration of the function @{term F} *}

consts  iterates :: "[i=>i,i,i] => i"   ("(_^_ '(_'))" [60,1000,1000] 60)

primrec
    "F^0 (x) = x"
    "F^(succ(n)) (x) = F(F^n (x))"

definition
  iterates_omega :: "[i=>i,i] => i"  where
    "iterates_omega(F,x) == \<Union>n\<in>nat. F^n (x)"

notation (xsymbols)
  iterates_omega  ("(_^\<omega> '(_'))" [60,1000] 60)
notation (HTML output)
  iterates_omega  ("(_^\<omega> '(_'))" [60,1000] 60)

lemma iterates_triv:
     "[| n\<in>nat;  F(x) = x |] ==> F^n (x) = x"
by (induct n rule: nat_induct, simp_all)

lemma iterates_type [TC]:
     "[| n \<in> nat;  a \<in> A; !!x. x \<in> A ==> F(x) \<in> A |]
      ==> F^n (a) \<in> A"
by (induct n rule: nat_induct, simp_all)

lemma iterates_omega_triv:
    "F(x) = x ==> F^\<omega> (x) = x"
by (simp add: iterates_omega_def iterates_triv)

lemma Ord_iterates [simp]:
     "[| n\<in>nat;  !!i. Ord(i) ==> Ord(F(i));  Ord(x) |]
      ==> Ord(F^n (x))"
by (induct n rule: nat_induct, simp_all)

lemma iterates_commute: "n \<in> nat ==> F(F^n (x)) = F^n (F(x))"
by (induct_tac n, simp_all)

subsection{* Transfinite Recursion *}

text{*Transfinite recursion for definitions based on the
    three cases of ordinals*}

definition
  transrec3 :: "[i, i, [i,i]=>i, [i,i]=>i] =>i" where
    "transrec3(k, a, b, c) ==
       transrec(k, \<lambda>x r.
         if x=0 then a
         else if Limit(x) then c(x, \<lambda>y\<in>x. r`y)
         else b(Arith.pred(x), r ` Arith.pred(x)))"

lemma transrec3_0 [simp]: "transrec3(0,a,b,c) = a"
by (rule transrec3_def [THEN def_transrec, THEN trans], simp)

lemma transrec3_succ [simp]:
     "transrec3(succ(i),a,b,c) = b(i, transrec3(i,a,b,c))"
by (rule transrec3_def [THEN def_transrec, THEN trans], simp)

lemma transrec3_Limit:
     "Limit(i) ==>
      transrec3(i,a,b,c) = c(i, \<lambda>j\<in>i. transrec3(j,a,b,c))"
by (rule transrec3_def [THEN def_transrec, THEN trans], force)

declaration {* fn _ =>
  Simplifier.map_ss (Simplifier.set_mksimps (K (map mk_eq o Ord_atomize o gen_all)))
*}

end