theory PSem
imports Main OpSem_Proof_Rules
begin

datatype object_type = pointer | variable     (*object types to be added, specifically variable?*)

type_synonym address = nat
type_synonym id = nat

record posem =
  A :: "id \<Rightarrow> (L \<times> object_type) option"
  alloc_addrs :: "L set"  (* allocation *)
  obj_ctr :: "nat"            (*always increasing with \<forall>i.i\<ge>obj_ctr s \<longrightarrow> A(i) = None*)
                              (* have old pointers *s point to 0, if freed/detached or current value of C - in critical*)

definition "codomain_of_A ps \<equiv> \<Union>{{fst(alloc)} | alloc. alloc \<in> ran(A ps)}"

definition "isfree_addr a ps \<equiv> a\<notin>(alloc_addrs ps) "

definition "constant_alloc_ass ps \<equiv> \<forall>loc. (loc \<in> alloc_addrs ps \<longleftrightarrow> loc \<in> codomain_of_A ps)
                                         \<and>(loc \<notin> alloc_addrs ps \<longleftrightarrow> loc \<notin> codomain_of_A ps)"

definition "Unique_allocs ps \<equiv> \<forall>prov alloc b. (A ps prov) = Some (alloc,b) \<longrightarrow> (\<nexists>prov' b'.
                                        prov\<noteq>prov' \<and> (A ps prov') = Some (alloc,b'))"

definition "psem_rules ps \<equiv> Unique_allocs ps \<and> constant_alloc_ass ps"

lemmas alloc_general_lemmas [simp] = codomain_of_A_def isfree_addr_def constant_alloc_ass_def
                                      Unique_allocs_def psem_rules_def

lemma " psem_rules ps \<Longrightarrow> isfree_addr loc ps \<Longrightarrow> loc\<notin> codomain_of_A ps"
  using alloc_general_lemmas isfree_addr_def by blast

definition "allocate_object ps loc prov ps' typ \<equiv> isfree_addr loc ps \<and> prov \<notin> dom(A ps)
 \<and> ps' = ps\<lparr>A := (A ps) (prov:=Some (loc, typ)),
            alloc_addrs := (alloc_addrs ps \<union> {loc})\<rparr>"

definition "kill ps prov ps' \<equiv> \<exists>x. (prov \<in> dom(A ps) \<and> Some x = A ps prov
\<and> ps' = ps \<lparr> A:= (A ps) (prov:= None),
            alloc_addrs := (alloc_addrs ps - {fst(x)})\<rparr>)"

lemmas alloc_operation_lemmas [simp] = allocate_object_def kill_def

lemma set_alloc_addr_lem1:
  "allocate_object ps loc prov ps' typ
  \<Longrightarrow> prov \<notin> dom(A ps)"
  by auto

lemma set_alloc_addr_lem2:
  "allocate_object ps loc prov ps' typ
  \<Longrightarrow> prov \<in> dom(A ps')"
  by auto

lemma temp_lemma1:
  "constant_alloc_ass ps \<Longrightarrow> loc \<in> alloc_addrs ps \<Longrightarrow> loc \<in> codomain_of_A ps"
  by (simp)
lemma temp_lemma2:
  "constant_alloc_ass ps \<Longrightarrow> loc \<in> codomain_of_A ps \<Longrightarrow> loc \<in> alloc_addrs ps"
  by (simp)
lemma temp_lemma3:
  "constant_alloc_ass ps \<Longrightarrow> loc \<notin> alloc_addrs ps \<Longrightarrow> loc \<notin> codomain_of_A ps"
  by (simp)
lemma temp_lemma4:
  "constant_alloc_ass ps \<Longrightarrow> loc \<notin> codomain_of_A ps \<Longrightarrow> loc \<notin> alloc_addrs ps"
  by (simp)

lemma uniqueness_lemma1:
  "constant_alloc_ass ps \<Longrightarrow> Unique_allocs ps \<Longrightarrow>
 loca \<in> codomain_of_A ps \<Longrightarrow>
 locb \<in> alloc_addrs ps \<Longrightarrow>
 prova=provb \<Longrightarrow> fst(the(A ps prova)) = loca \<Longrightarrow> fst(the(A ps provb)) = locb \<Longrightarrow> loca=locb"
  by (simp)

lemma uniqueness_lemma2:
  "constant_alloc_ass ps \<Longrightarrow> Unique_allocs ps \<Longrightarrow>
 \<not>isfree_addr loca ps \<Longrightarrow>
 \<not>isfree_addr locb ps \<Longrightarrow>
 prova=provb \<Longrightarrow> fst(the(A ps prova)) = loca \<Longrightarrow> fst(the(A ps provb)) = locb \<Longrightarrow> loca=locb"
  by (simp)

lemma uniqueness_lemma3:
  "constant_alloc_ass ps \<Longrightarrow>
 isfree_addr loca ps \<Longrightarrow>
 loca \<notin> codomain_of_A ps"
  by simp
lemma uniqueness_lemma4:
  "constant_alloc_ass ps \<Longrightarrow>
 isfree_addr loca ps \<Longrightarrow>
 \<nexists>prova b. A ps prova = Some (loca,b)"
  apply simp
  by (metis insertI1 ranI)

lemma uniqueness_lemma5:
  "constant_alloc_ass ps \<Longrightarrow>
 isfree_addr loca ps \<Longrightarrow>
A ps 1 = Some (1, pointer) \<Longrightarrow>
A ps 2 = Some (1, variable)
\<Longrightarrow>
\<not> Unique_allocs ps "
  apply simp
  by (metis n_not_Suc_n numeral_2_eq_2)

lemma alloc_step_1:
  assumes "prov \<notin> dom(A ps)"
  and "isfree_addr loc ps"
  and "allocate_object ps loc prov ps' typ"
shows "prov \<in> dom(A ps')"
  using assms by simp

lemma alloc_step_2:
  assumes "prov \<notin> dom(A ps)"
  and "isfree_addr loc ps"
  and "allocate_object ps loc prov ps' typ"
shows "\<not>(isfree_addr loc ps')"
  using assms by simp

lemma alloc_step_3:
  assumes "prov \<notin> dom(A ps)"
  and "isfree_addr loc ps"
  and "allocate_object ps loc prov ps' typ"
shows "\<not>(isfree_addr loc ps')"
  using assms by simp

lemma kill_preserves_structure_1:
  assumes "constant_alloc_ass ps"
  and "kill ps prov ps'"
  and "\<exists>b. A ps prov = Some(loc, b)"
shows "isfree_addr loc ps'"
  using assms apply simp
  apply clarify
  by auto

lemma kill_preserves_structure_2:
  assumes "constant_alloc_ass ps"
  and "kill ps prov ps'"
  and "Unique_allocs ps"
  and "\<exists>b. A ps prov = Some(loc, b)"
shows "loc \<notin> codomain_of_A ps'"
  using assms apply simp
  apply clarify apply auto
  by (metis ComplD insertCI ran_restrictD restrict_complement_singleton_eq)

lemma kill_preserves_structure_3:
  assumes "constant_alloc_ass ps"
  and "kill ps prov ps'"
  and "Unique_allocs ps"
  and "\<exists>b. A ps prov = Some(loc, b)"
shows "\<nexists>prov b. A ps' prov = Some(loc, b)"
  using assms apply simp
  apply clarify apply auto
  by (metis option.discI)

lemma allocation_preserves_structure:
  assumes "prov \<notin> dom(A ps)"
  and "constant_alloc_ass ps"
  and "isfree_addr loc ps"
  and "allocate_object ps loc prov ps' typ"
shows "constant_alloc_ass ps'"
  using assms apply simp
  apply clarify
  by (smt (z3) assms(1) domIff insert_iff old.prod.inject ran_map_upd singletonD)

lemma kill_preserves_structure:
  assumes "constant_alloc_ass ps"
  and "kill ps prov ps'"
  and "Unique_allocs ps"
  and "\<exists>b. A ps prov = Some(loc, b)"
shows "constant_alloc_ass ps'"
  using assms apply simp
  apply clarify apply auto
  apply (smt (z3) Compl_insert Diff_insert_absorb Pair_inject empty_iff fun_upd_same fun_upd_triv fun_upd_upd insertE insert_Diff insert_absorb insert_absorb insert_compr insert_ident insert_iff insert_iff mk_disjoint_insert ranI ran_map_upd restrict_complement_singleton_eq singletonI)
  apply (metis (no_types, lifting) insert_iff ranI ran_restrictD restrict_complement_singleton_eq)
  apply (metis ComplD insertCI option.sel ran_restrictD restrict_complement_singleton_eq)
  apply (metis (no_types, lifting) insert_iff ranI ran_restrictD restrict_complement_singleton_eq)
  apply (metis ComplD insertCI option.sel ran_restrictD restrict_complement_singleton_eq)
  by (smt (z3) Compl_insert Diff_insert_absorb Pair_inject empty_iff fun_upd_same fun_upd_triv fun_upd_upd insertE insert_Diff insert_absorb insert_absorb insert_compr insert_ident insert_iff insert_iff mk_disjoint_insert ranI ran_map_upd restrict_complement_singleton_eq singletonI)

lemma allocation_preserves_uniqueness_sup_1:
  assumes "prov \<notin> dom(A ps)"
  and "constant_alloc_ass ps"
  and "Unique_allocs ps"
  and "isfree_addr loc ps"
  and "allocate_object ps loc prov ps' typ"
shows "constant_alloc_ass ps'"
  using assms allocation_preserves_structure [where ps = ps and ps'=ps']
  by blast

lemma allocation_preserves_uniqueness:
  assumes "prov \<notin> dom(A ps)"
  and "constant_alloc_ass ps"
  and "Unique_allocs ps"
  and "isfree_addr loc ps"
  and "allocate_object ps loc prov ps' typ"
shows "Unique_allocs ps'"
  using assms apply simp
  apply clarify apply auto prefer 2
  apply (metis (no_types) insertI1 ranI)
  by (metis (no_types) insertI1 ranI)

lemma kill_preserves_uniqueness:
  assumes "constant_alloc_ass ps"
  and "kill ps prov ps'"
  and "Unique_allocs ps"
  and "\<exists>b. A ps prov = Some(loc, b)"
shows "Unique_allocs ps'"
  using assms apply simp
  apply clarify apply auto
  by (metis option.discI)

end

github-repos/isabelle/MSemenyuk-PhD_Isabelle/PhD_Isabelle-179f5d346a721b15940a271323e3487f4ea51338/Treiber Stack C11/PSem (Brijesh Dongol's conflicted copy 2022-11-01).thy


(*  Title:      Partial_Radication.thy
    Author:     Klaus Weidinger, TU Muenchen
    Copyright   2020

A simproc for the function "root (n::nat) (x::nat)" from "NthRoot.thy".
*)

theory Partial_Radication
  imports
    Complex_Main
    "HOL-Computational_Algebra.Primes"
    "HOL-Computational_Algebra.Nth_Powers"
    HOL.Num
    "HOL.Real"
begin

text\<open>
Case distinction:
  case "n = 0": lemma 'root_0' from 'NthRoot.thy'
  case "n = 1": lemma 'root_1'
  case "n > 1": lemma 'partial_radication'
\<close>

lemma partial_radication:
  fixes n::nat and x::nat and c::nat and x'::nat
  assumes "x = x' * c ^ n" "c > 0" "n > 1"
  shows "root n (real x) \<equiv> c * root n (real x')"
proof -
  have "0 \<le> c"
    using assms(2) by auto
  hence "root n (real x) = root n (real x') * root n (real (c ^ n))"
    using assms by (auto simp: real_root_mult)
  hence "root n (real x) = root n (real x') * c"
    using assms by (auto simp: real_root_power_cancel)
  hence "root n (real x) = c * root n (real x')"
    by simp
  thus "root n (real x) \<equiv> c * root n (real x')" by (simp add: eq_reflection)
qed

lemma root_0': "root 0 (real (x::nat)) \<equiv> 0"
  by simp

lemma root_1: "root 1 (real (x::nat)) \<equiv> x"
  by simp

ML_file\<open>algorithms.ML\<close>
ML_file\<open>tools.ML\<close>

ML\<open>
signature PARTIAL_RADICATION =
sig

(* defines the upper (and lower) bound for the simproc *)
val limit: int Config.T

val parse: Thm.cterm -> int * int

(*                                n     x      c     x'   *)
datatype cert = P_RADIX_CERT of (int * int) * int * int | ZEROTH_ROOT of int | FIRST_ROOT of int
val mk_cert: int -> int -> cert
val generate_proof: Proof.context -> cert -> thm option

val prove: Proof.context -> int * int -> thm option
val simproc: Proof.context -> Thm.cterm -> thm option

(* helper tools *)
val get_cert_numbers : cert -> int * int

end

structure Partial_Radication : PARTIAL_RADICATION =
struct

val limit = Attrib.setup_config_int \<^binding>\<open>limit\<close> (K 1000000);
exception LIMIT

(*                                n     x      c     x'   *)
datatype cert = P_RADIX_CERT of (int * int) * int * int | ZEROTH_ROOT of int | FIRST_ROOT of int

fun parse ct = Tools.parseZR ct @{const_name "root"}

fun mk_cert n x =
    if n = 0 then ZEROTH_ROOT x else
    if n = 1 then FIRST_ROOT x else
    let
        val fs_mset = Algorithms.to_mset (Algorithms.factorize x)
        fun p_radix acc_c acc_x' (n, x) ((p, m)::pms) = p_radix ((p, m div n)::acc_c) ((p, m mod n)::acc_x') (n, x) pms
          | p_radix acc_c acc_x' (n, x) [] = P_RADIX_CERT ((n, x), Algorithms.prod_mset acc_c, Algorithms.prod_mset acc_x')
    in
        p_radix [] [] (n, x) fs_mset
    end

exception ERROR
fun generate_proof ctxt (ZEROTH_ROOT x) =
        @{thm root_0'}
            |> Drule.infer_instantiate' ctxt [Tools.nat2ct' ctxt x]
            |> SOME
  | generate_proof ctxt (FIRST_ROOT x) =
        @{thm root_1}
            |> Drule.infer_instantiate' ctxt [Tools.nat2ct' ctxt x]
            |> SOME
  | generate_proof ctxt (P_RADIX_CERT ((n, x), c, x')) =
        if c = 1 then raise ERROR else
        @{thm partial_radication}
            |> Drule.infer_instantiate' ctxt
                      (map (Tools.nat2ct' ctxt) [x, x', c, n])
            |> Tools.simp ctxt 2
            |> SOME

fun prove ctxt (n, x) =               (* (n, x)         *)
    (n,x) |-> mk_cert                 (* cert           *)
          |> generate_proof ctxt      (* thm option     *)
    handle ERROR => NONE

fun simproc ctxt input =            (* term            *)
    input |> parse                  (* n, x            *)
          |> (fn (n, x) => if abs x < Config.get ctxt limit then (n, x) else raise LIMIT)
          |> prove ctxt             (* thm option      *)
    handle LIMIT => NONE
         | TERM _ => NONE

(* helper tools *)
fun get_cert_numbers (ZEROTH_ROOT x) = (0, x)
  | get_cert_numbers (FIRST_ROOT x) = (1, x)
  | get_cert_numbers (P_RADIX_CERT ((n, x), _, _)) = (n, x)

end
\<close>

simproc_setup root_simproc ("root (numeral n::nat) (real (numeral x::nat))") = \<open>K Partial_Radication.simproc\<close>

end


(*  File:       Drop_Module.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Karsten Diekhoff, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Jonas Kraemer, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Drop Module\<close>

theory Drop_Module
  imports "Component_Types/Electoral_Module"
begin

text
\<open>This is a family of electoral modules. For a natural number n and a
lexicon (linear order) r of all alternatives, the according drop module
rejects the lexicographically first n alternatives (from A) and
defers the rest.
It is primarily used as counterpart to the pass module in a
parallel composition, in order to segment the alternatives into
two groups.\<close>

subsection \<open>Definition\<close>

fun drop_module :: "nat \<Rightarrow> 'a Preference_Relation \<Rightarrow> 'a Electoral_Module" where
  "drop_module n r A p vs =
    ({},
    {a \<in> A. card(above (limit A r) a) \<le> n},
    {a \<in> A. card(above (limit A r) a) > n})"

subsection \<open>Soundness\<close>

theorem drop_mod_sound[simp]:
  assumes order: "linear_order r"
  shows "electoral_module (drop_module n r)"
proof -
  let ?mod = "drop_module n r"
  have
    "\<forall>A p. finite_profile A p \<longrightarrow>
        (\<forall>a \<in> A. a \<in> {x \<in> A. card(above (limit A r) x) \<le> n} \<or>
            a \<in> {x \<in> A. card(above (limit A r) x) > n})"
    by auto
  hence
    "\<forall>A p. finite_profile A p \<longrightarrow>
        {a \<in> A. card(above (limit A r) a) \<le> n} \<union>
        {a \<in> A. card(above (limit A r) a) > n} = A"
    by blast
  hence 0:
    "\<forall>A p. finite_profile A p \<longrightarrow>
        set_equals_partition A (drop_module n r A p vs)"
    by simp
  have
    "\<forall>A p. finite_profile A p \<longrightarrow>
        (\<forall>a \<in> A. \<not>(a \<in> {x \<in> A. card(above (limit A r) x) \<le> n} \<and>
            a \<in> {x \<in> A. card(above (limit A r) x) > n}))"
    by auto
  hence
    "\<forall>A p. finite_profile A p \<longrightarrow>
        {a \<in> A. card(above (limit A r) a) \<le> n} \<inter>
        {a \<in> A. card(above (limit A r) a) > n} = {}"
    by blast
  hence 1: "\<forall>A p vs. finite_profile A p \<longrightarrow> disjoint3 (?mod A p vs)"
    by simp
  from 0 1 have
    "\<forall>A p vs. finite_profile A p \<longrightarrow>
        well_formed A (?mod A p vs)"
    by simp
  hence
    "\<forall>A p vs. finite_profile A p \<longrightarrow>
        well_formed A (?mod A p vs)"
    by simp
  thus ?thesis
    using electoral_modI
    by metis
qed

subsection \<open>Non-Electing\<close>

(*The drop module is non-electing.*)
theorem drop_mod_non_electing[simp]:
  assumes order: "linear_order r"
  shows "non_electing (drop_module n r)"
  by (simp add: non_electing_def order)

subsection \<open>Properties\<close>

(*The drop module is strictly defer-monotone.*)
theorem drop_mod_def_lift_inv[simp]:
  assumes order: "linear_order r"
  shows "defer_lift_invariance (drop_module n r)"
  by (simp add: order defer_lift_invariance_def)

end


(*  Title:      FOLP/ex/Propositional_Int.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge
*)

section {* First-Order Logic: propositional examples *}

theory Propositional_Int
imports IFOLP
begin

text "commutative laws of & and | "
schematic_lemma "?p : P & Q  -->  Q & P"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

schematic_lemma "?p : P | Q  -->  Q | P"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

text "associative laws of & and | "
schematic_lemma "?p : (P & Q) & R  -->  P & (Q & R)"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

schematic_lemma "?p : (P | Q) | R  -->  P | (Q | R)"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

text "distributive laws of & and | "
schematic_lemma "?p : (P & Q) | R  --> (P | R) & (Q | R)"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

schematic_lemma "?p : (P | R) & (Q | R)  --> (P & Q) | R"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

schematic_lemma "?p : (P | Q) & R  --> (P & R) | (Q & R)"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

schematic_lemma "?p : (P & R) | (Q & R)  --> (P | Q) & R"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

text "Laws involving implication"

schematic_lemma "?p : (P-->R) & (Q-->R) <-> (P|Q --> R)"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

schematic_lemma "?p : (P & Q --> R) <-> (P--> (Q-->R))"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

schematic_lemma "?p : ((P-->R)-->R) --> ((Q-->R)-->R) --> (P&Q-->R) --> R"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

schematic_lemma "?p : ~(P-->R) --> ~(Q-->R) --> ~(P&Q-->R)"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

schematic_lemma "?p : (P --> Q & R) <-> (P-->Q)  &  (P-->R)"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

text "Propositions-as-types"

(*The combinator K*)
schematic_lemma "?p : P --> (Q --> P)"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

(*The combinator S*)
schematic_lemma "?p : (P-->Q-->R)  --> (P-->Q) --> (P-->R)"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

(*Converse is classical*)
schematic_lemma "?p : (P-->Q) | (P-->R)  -->  (P --> Q | R)"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

schematic_lemma "?p : (P-->Q)  -->  (~Q --> ~P)"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

text "Schwichtenberg's examples (via T. Nipkow)"

schematic_lemma stab_imp: "?p : (((Q-->R)-->R)-->Q) --> (((P-->Q)-->R)-->R)-->P-->Q"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

schematic_lemma stab_to_peirce: "?p : (((P --> R) --> R) --> P) --> (((Q --> R) --> R) --> Q)
              --> ((P --> Q) --> P) --> P"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

schematic_lemma peirce_imp1: "?p : (((Q --> R) --> Q) --> Q)
               --> (((P --> Q) --> R) --> P --> Q) --> P --> Q"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

schematic_lemma peirce_imp2: "?p : (((P --> R) --> P) --> P) --> ((P --> Q --> R) --> P) --> P"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

schematic_lemma mints: "?p : ((((P --> Q) --> P) --> P) --> Q) --> Q"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

schematic_lemma mints_solovev: "?p : (P --> (Q --> R) --> Q) --> ((P --> Q) --> R) --> R"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

schematic_lemma tatsuta: "?p : (((P7 --> P1) --> P10) --> P4 --> P5)
          --> (((P8 --> P2) --> P9) --> P3 --> P10)
          --> (P1 --> P8) --> P6 --> P7
          --> (((P3 --> P2) --> P9) --> P4)
          --> (P1 --> P3) --> (((P6 --> P1) --> P2) --> P9) --> P5"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

schematic_lemma tatsuta1: "?p : (((P8 --> P2) --> P9) --> P3 --> P10)
     --> (((P3 --> P2) --> P9) --> P4)
     --> (((P6 --> P1) --> P2) --> P9)
     --> (((P7 --> P1) --> P10) --> P4 --> P5)
     --> (P1 --> P3) --> (P1 --> P8) --> P6 --> P7 --> P5"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

end


(*  Title:      HOL/UNITY/Comp/Progress.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   2003  University of Cambridge

David Meier's thesis
*)

section\<open>Progress Set Examples\<close>

theory Progress imports "../UNITY_Main" begin

subsection \<open>The Composition of Two Single-Assignment Programs\<close>
text\<open>Thesis Section 4.4.2\<close>

definition FF :: "int program" where
    "FF = mk_total_program (UNIV, {range (\<lambda>x. (x, x+1))}, UNIV)"

definition GG :: "int program" where
    "GG = mk_total_program (UNIV, {range (\<lambda>x. (x, 2*x))}, UNIV)"

subsubsection \<open>Calculating @{term "wens_set FF (atLeast k)"}\<close>

lemma Domain_actFF: "Domain (range (\<lambda>x::int. (x, x + 1))) = UNIV"
by force

lemma FF_eq:
      "FF = mk_program (UNIV, {range (\<lambda>x. (x, x+1))}, UNIV)"
by (simp add: FF_def mk_total_program_def totalize_def totalize_act_def
              program_equalityI Domain_actFF)

lemma wp_actFF:
     "wp (range (\<lambda>x::int. (x, x + 1))) (atLeast k) = atLeast (k - 1)"
by (force simp add: wp_def)

lemma wens_FF: "wens FF (range (\<lambda>x. (x, x+1))) (atLeast k) = atLeast (k - 1)"
by (force simp add: FF_eq wens_single_eq wp_actFF)

lemma single_valued_actFF: "single_valued (range (\<lambda>x::int. (x, x + 1)))"
by (force simp add: single_valued_def)

lemma wens_single_finite_FF:
     "wens_single_finite (range (\<lambda>x. (x, x+1))) (atLeast k) n =
      atLeast (k - int n)"
apply (induct n, simp)
apply (force simp add: wens_FF
            def_wens_single_finite_Suc_eq_wens [OF FF_eq single_valued_actFF])
done

lemma wens_single_FF_eq_UNIV:
     "wens_single (range (\<lambda>x::int. (x, x + 1))) (atLeast k) = UNIV"
apply (auto simp add: wens_single_eq_Union)
apply (rule_tac x="nat (k-x)" in exI)
apply (simp add: wens_single_finite_FF)
done

lemma wens_set_FF:
     "wens_set FF (atLeast k) = insert UNIV (atLeast ` atMost k)"
apply (auto simp add: wens_set_single_eq [OF FF_eq single_valued_actFF]
                      wens_single_FF_eq_UNIV wens_single_finite_FF)
apply (erule notE)
apply (rule_tac x="nat (k-xa)" in range_eqI)
apply (simp add: wens_single_finite_FF)
done

subsubsection \<open>Proving @{term "FF \<in> UNIV leadsTo atLeast (k::int)"}\<close>

lemma atLeast_ensures: "FF \<in> atLeast (k - 1) ensures atLeast (k::int)"
apply (simp add: Progress.wens_FF [symmetric] wens_ensures)
apply (simp add: wens_ensures FF_eq)
done

lemma atLeast_leadsTo: "FF \<in> atLeast (k - int n) leadsTo atLeast (k::int)"
apply (induct n)
 apply (simp_all add: leadsTo_refl)
apply (rule_tac A = "atLeast (k - int n - 1)" in leadsTo_weaken_L)
 apply (blast intro: leadsTo_Trans atLeast_ensures, force)
done

lemma UN_atLeast_UNIV: "(\<Union>n. atLeast (k - int n)) = UNIV"
apply auto
apply (rule_tac x = "nat (k - x)" in exI, simp)
done

lemma FF_leadsTo: "FF \<in> UNIV leadsTo atLeast (k::int)"
apply (subst UN_atLeast_UNIV [symmetric])
apply (rule leadsTo_UN [OF atLeast_leadsTo])
done

text\<open>Result (4.39): Applying the leadsTo-Join Theorem\<close>
theorem "FF\<squnion>GG \<in> atLeast 0 leadsTo atLeast (k::int)"
apply (subgoal_tac "FF\<squnion>GG \<in> (atLeast 0 \<inter> atLeast 0) leadsTo atLeast k")
 apply simp
apply (rule_tac T = "atLeast 0" in leadsTo_Join)
  apply (rule leadsTo_weaken_L [OF FF_leadsTo], simp)
 apply (simp add: awp_iff_constrains FF_def, safety)
apply (simp add: awp_iff_constrains GG_def wens_set_FF, safety)
done

end


(* Author: Tobias Nipkow and Gerwin Klein *)

section "Compiler for IMP"

theory Compiler imports Big_Step Star
begin

subsection "List setup"

text {*
  In the following, we use the length of lists as integers
  instead of natural numbers. Instead of converting @{typ nat}
  to @{typ int} explicitly, we tell Isabelle to coerce @{typ nat}
  automatically when necessary.
*}
declare [[coercion_enabled]]
declare [[coercion "int :: nat \<Rightarrow> int"]]

text {*
  Similarly, we will want to access the ith element of a list,
  where @{term i} is an @{typ int}.
*}

abbreviation inth :: "'a list \<Rightarrow> int \<Rightarrow> 'a" (infixl "!!" 100) where
  "l!!i \<equiv> l ! (nat i)"

text {*
  The only additional lemma we need about this function
  is indexing over append:
*}
lemma inth_append [simp]:
  "0 \<le> i \<Longrightarrow>
  (xs @ ys) !! i = (if i < size xs then xs !! i else ys !! (i - size xs))"
  by (auto simp: nth_append nat_diff_distrib)

text{* We hide coercion @{const int} applied to @{const length}: *}

abbreviation (output)
  "isize xs == int (length xs)"

notation isize ("size")

subsection "Instructions and Stack Machine"

text_raw{*\snip{instrdef}{0}{1}{% *}
datatype instr =
  LOADI int | LOAD vname | ADD | STORE vname |
  JMP int | JMPLESS int | JMPGE int
text_raw{*}%endsnip*}

type_synonym stack = "val list"
type_synonym config = "int \<times> state \<times> stack"

(*
abbreviation "hd2 xs == hd(tl xs)"
abbreviation "tl2 xs == tl(tl xs)"
*)

fun iexec :: "instr \<Rightarrow> config \<Rightarrow> config" where
  "iexec (LOADI n) (i,s,stk) = (i+1,s,n#stk)"
| "iexec (LOAD x) (i,s,stk) = (i+1,s,s x # stk)"
| "iexec (ADD) (i,s,a1#a2#stk) = (i+1,s,(a1+a2) # stk)"
| "iexec (STORE x) (i,s,a#stk) = (i+1,s(x:=a),stk)"
| "iexec (JMP n) (i,s,stk) = (i+1+n,s,stk)"
| "iexec (JMPLESS n) (i,s,a1#a2#stk) = (if a2<a1 then i+1+n else i+1,s,stk)"
| "iexec (JMPGE n) (i,s,a1#a2#stk) = (if a2\<ge>a1 then i+1+n else i+1,s,stk)"
| "iexec (ADD) (i,_,_) = (i+1,undefined,undefined)"
| "iexec (STORE _) (i,_,_) = (i+1,undefined,undefined)"
| "iexec (JMPLESS _) (i,_,_) = (i+1,undefined,undefined)"
| "iexec (JMPGE n) (i,_,_) = (i+1+n,undefined,undefined)"

(*fun iexec :: "instr \<Rightarrow> config \<Rightarrow> config" where
"iexec instr (i,s,stk) = (case instr of
  LOADI n \<Rightarrow> (i+1,s, n#stk) |
  LOAD x \<Rightarrow> (i+1,s, s x # stk) |
  ADD \<Rightarrow> (i+1,s, (hd2 stk + hd stk) # tl2 stk) |
  STORE x \<Rightarrow> (i+1,s(x := hd stk),tl stk) |
  JMP n \<Rightarrow>  (i+1+n,s,stk) |
  JMPLESS n \<Rightarrow> (if hd2 stk < hd stk then i+1+n else i+1,s,tl2 stk) |
  JMPGE n \<Rightarrow> (if hd2 stk >= hd stk then i+1+n else i+1,s,tl2 stk))"
*)

definition
  exec1 :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool"
     ("(_/ \<turnstile> (_ \<rightarrow>/ _))" [59,0,59] 60)
where
  "P \<turnstile> c \<rightarrow> c' =
  (\<exists>i s stk. c = (i,s,stk) \<and> c' = iexec(P!!i) (i,s,stk) \<and> 0 \<le> i \<and> i < size P)"

lemma exec1I [intro, code_pred_intro]:
  "c' = iexec (P!!i) (i,s,stk) \<Longrightarrow> 0 \<le> i \<Longrightarrow> i < size P
  \<Longrightarrow> P \<turnstile> (i,s,stk) \<rightarrow> c'"
by (simp add: exec1_def)

abbreviation
  exec :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool" ("(_/ \<turnstile> (_ \<rightarrow>*/ _))" 50)
where
  "exec P \<equiv> star (exec1 P)"

lemmas exec_induct = star.induct [of "exec1 P", split_format(complete)]

code_pred exec1 by (metis exec1_def)

values
  "{(i,map t [''x'',''y''],stk) | i t stk.
    [LOAD ''y'', STORE ''x''] \<turnstile>
    (0, <''x'' := 3, ''y'' := 4>, []) \<rightarrow>* (i,t,stk)}"

subsection{* Verification infrastructure *}

text{* Below we need to argue about the execution of code that is embedded in
larger programs. For this purpose we show that execution is preserved by
appending code to the left or right of a program. *}

lemma iexec_shift [simp]:
  "((n+i',s',stk') = iexec x (n+i,s,stk)) = ((i',s',stk') = iexec x (i,s,stk))"
  by (cases "(x,(i,s,stk))" rule: iexec.cases) auto

lemma exec1_appendR: "P \<turnstile> c \<rightarrow> c' \<Longrightarrow> P@P' \<turnstile> c \<rightarrow> c'"
by (auto simp: exec1_def)

lemma exec_appendR: "P \<turnstile> c \<rightarrow>* c' \<Longrightarrow> P@P' \<turnstile> c \<rightarrow>* c'"
by (induction rule: star.induct) (fastforce intro: star.step exec1_appendR)+

lemma exec1_appendL:
  fixes i i' :: int
  shows
  "P \<turnstile> (i,s,stk) \<rightarrow> (i',s',stk') \<Longrightarrow>
   P' @ P \<turnstile> (size(P')+i,s,stk) \<rightarrow> (size(P')+i',s',stk')"
  unfolding exec1_def
  by (auto simp del: iexec.simps)

lemma exec_appendL:
  fixes i i' :: int
  shows
 "P \<turnstile> (i,s,stk) \<rightarrow>* (i',s',stk')  \<Longrightarrow>
  P' @ P \<turnstile> (size(P')+i,s,stk) \<rightarrow>* (size(P')+i',s',stk')"
  by (induction rule: exec_induct) (blast intro: star.step exec1_appendL)+

text{* Now we specialise the above lemmas to enable automatic proofs of
@{prop "P \<turnstile> c \<rightarrow>* c'"} where @{text P} is a mixture of concrete instructions and
pieces of code that we already know how they execute (by induction), combined
by @{text "@"} and @{text "#"}. Backward jumps are not supported.
The details should be skipped on a first reading.

If we have just executed the first instruction of the program, drop it: *}

lemma exec_Cons_1 [intro]:
  "P \<turnstile> (0,s,stk) \<rightarrow>* (j,t,stk') \<Longrightarrow>
  instr#P \<turnstile> (1,s,stk) \<rightarrow>* (1+j,t,stk')"
by (drule exec_appendL[where P'="[instr]"]) simp

lemma exec_appendL_if[intro]:
  fixes i i' j :: int
  shows
  "size P' <= i
   \<Longrightarrow> P \<turnstile> (i - size P',s,stk) \<rightarrow>* (j,s',stk')
   \<Longrightarrow> i' = size P' + j
   \<Longrightarrow> P' @ P \<turnstile> (i,s,stk) \<rightarrow>* (i',s',stk')"
by (drule exec_appendL[where P'=P']) simp

text{* Split the execution of a compound program up into the execution of its
parts: *}

lemma exec_append_trans[intro]:
  fixes i' i'' j'' :: int
  shows
"P \<turnstile> (0,s,stk) \<rightarrow>* (i',s',stk') \<Longrightarrow>
 size P \<le> i' \<Longrightarrow>
 P' \<turnstile>  (i' - size P,s',stk') \<rightarrow>* (i'',s'',stk'') \<Longrightarrow>
 j'' = size P + i''
 \<Longrightarrow>
 P @ P' \<turnstile> (0,s,stk) \<rightarrow>* (j'',s'',stk'')"
by(metis star_trans[OF exec_appendR exec_appendL_if])

declare Let_def[simp]

subsection "Compilation"

fun acomp :: "aexp \<Rightarrow> instr list" where
"acomp (N n) = [LOADI n]" |
"acomp (V x) = [LOAD x]" |
"acomp (Plus a1 a2) = acomp a1 @ acomp a2 @ [ADD]"

lemma acomp_correct[intro]:
  "acomp a \<turnstile> (0,s,stk) \<rightarrow>* (size(acomp a),s,aval a s#stk)"
by (induction a arbitrary: stk) fastforce+

fun bcomp :: "bexp \<Rightarrow> bool \<Rightarrow> int \<Rightarrow> instr list" where
"bcomp (Bc v) f n = (if v=f then [JMP n] else [])" |
"bcomp (Not b) f n = bcomp b (\<not>f) n" |
"bcomp (And b1 b2) f n =
 (let cb2 = bcomp b2 f n;
        m = if f then size cb2 else (size cb2::int)+n;
      cb1 = bcomp b1 False m
  in cb1 @ cb2)" |
"bcomp (Less a1 a2) f n =
 acomp a1 @ acomp a2 @ (if f then [JMPLESS n] else [JMPGE n])"

value
  "bcomp (And (Less (V ''x'') (V ''y'')) (Not(Less (V ''u'') (V ''v''))))
     False 3"

lemma bcomp_correct[intro]:
  fixes n :: int
  shows
  "0 \<le> n \<Longrightarrow>
  bcomp b f n \<turnstile>
 (0,s,stk)  \<rightarrow>*  (size(bcomp b f n) + (if f = bval b s then n else 0),s,stk)"
proof(induction b arbitrary: f n)
  case Not
  from Not(1)[where f="~f"] Not(2) show ?case by fastforce
next
  case (And b1 b2)
  from And(1)[of "if f then size(bcomp b2 f n) else size(bcomp b2 f n) + n"
                 "False"]
       And(2)[of n f] And(3)
  show ?case by fastforce
qed fastforce+

fun ccomp :: "com \<Rightarrow> instr list" where
"ccomp SKIP = []" |
"ccomp (x ::= a) = acomp a @ [STORE x]" |
"ccomp (c\<^sub>1;;c\<^sub>2) = ccomp c\<^sub>1 @ ccomp c\<^sub>2" |
"ccomp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) =
  (let cc\<^sub>1 = ccomp c\<^sub>1; cc\<^sub>2 = ccomp c\<^sub>2; cb = bcomp b False (size cc\<^sub>1 + 1)
   in cb @ cc\<^sub>1 @ JMP (size cc\<^sub>2) # cc\<^sub>2)" |
"ccomp (WHILE b DO c) =
 (let cc = ccomp c; cb = bcomp b False (size cc + 1)
  in cb @ cc @ [JMP (-(size cb + size cc + 1))])"

value "ccomp
 (IF Less (V ''u'') (N 1) THEN ''u'' ::= Plus (V ''u'') (N 1)
  ELSE ''v'' ::= V ''u'')"

value "ccomp (WHILE Less (V ''u'') (N 1) DO (''u'' ::= Plus (V ''u'') (N 1)))"

subsection "Preservation of semantics"

lemma ccomp_bigstep:
  "(c,s) \<Rightarrow> t \<Longrightarrow> ccomp c \<turnstile> (0,s,stk) \<rightarrow>* (size(ccomp c),t,stk)"
proof(induction arbitrary: stk rule: big_step_induct)
  case (Assign x a s)
  show ?case by (fastforce simp:fun_upd_def cong: if_cong)
next
  case (Seq c1 s1 s2 c2 s3)
  let ?cc1 = "ccomp c1"  let ?cc2 = "ccomp c2"
  have "?cc1 @ ?cc2 \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cc1,s2,stk)"
    using Seq.IH(1) by fastforce
  moreover
  have "?cc1 @ ?cc2 \<turnstile> (size ?cc1,s2,stk) \<rightarrow>* (size(?cc1 @ ?cc2),s3,stk)"
    using Seq.IH(2) by fastforce
  ultimately show ?case by simp (blast intro: star_trans)
next
  case (WhileTrue b s1 c s2 s3)
  let ?cc = "ccomp c"
  let ?cb = "bcomp b False (size ?cc + 1)"
  let ?cw = "ccomp(WHILE b DO c)"
  have "?cw \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cb,s1,stk)"
    using `bval b s1` by fastforce
  moreover
  have "?cw \<turnstile> (size ?cb,s1,stk) \<rightarrow>* (size ?cb + size ?cc,s2,stk)"
    using WhileTrue.IH(1) by fastforce
  moreover
  have "?cw \<turnstile> (size ?cb + size ?cc,s2,stk) \<rightarrow>* (0,s2,stk)"
    by fastforce
  moreover
  have "?cw \<turnstile> (0,s2,stk) \<rightarrow>* (size ?cw,s3,stk)" by(rule WhileTrue.IH(2))
  ultimately show ?case by(blast intro: star_trans)
qed fastforce+

end


section \<open>Existence\<close>
theory Existence imports
  Piecewise_Continuous
begin

subsection \<open>Definition\<close>

definition has_laplace :: "(real \<Rightarrow> complex) \<Rightarrow> complex \<Rightarrow> complex \<Rightarrow> bool"
  (infixr "has'_laplace" 46)
  where "(f has_laplace L) s \<longleftrightarrow> ((\<lambda>t. exp (t *\<^sub>R - s) * f t) has_integral L) {0..}"

lemma has_laplaceI:
  assumes "((\<lambda>t. exp (t *\<^sub>R - s) * f t) has_integral L) {0..}"
  shows "(f has_laplace L) s"
  using assms
  by (auto simp: has_laplace_def)

lemma has_laplaceD:
  assumes "(f has_laplace L) s"
  shows "((\<lambda>t. exp (t *\<^sub>R - s) * f t) has_integral L) {0..}"
  using assms
  by (auto simp: has_laplace_def)

lemma has_laplace_unique:
  "L = M" if
  "(f has_laplace L) s"
  "(f has_laplace M) s"
  using that
  by (auto simp: has_laplace_def has_integral_unique)

subsection \<open>Condition for Existence: Exponential Order\<close>

definition "exponential_order M c f \<longleftrightarrow> 0 < M \<and> (\<forall>\<^sub>F t in at_top. norm (f t) \<le> M * exp (c * t))"

lemma exponential_orderI:
  assumes "0 < M" and eo: "\<forall>\<^sub>F t in at_top. norm (f t) \<le> M * exp (c * t)"
  shows "exponential_order M c f"
  by (auto intro!: assms simp: exponential_order_def)

lemma exponential_orderD:
  assumes "exponential_order M c f"
  shows "0 < M" "\<forall>\<^sub>F t in at_top. norm (f t) \<le> M * exp (c * t)"
  using assms by (auto simp: exponential_order_def)

context
  fixes f::"real \<Rightarrow> complex"
begin

definition laplace_integrand::"complex \<Rightarrow> real \<Rightarrow> complex"
  where "laplace_integrand s t = exp (t *\<^sub>R - s) * f t"

lemma laplace_integrand_absolutely_integrable_on_Icc:
  "laplace_integrand s absolutely_integrable_on {a..b}"
  if "AE x\<in>{a..b} in lebesgue. cmod (f x) \<le> B" "f integrable_on {a..b}"
  apply (cases "b \<le> a")
  subgoal by (auto intro!: absolutely_integrable_onI integrable_negligible[OF negligible_real_ivlI])
proof goal_cases
  case 1
  have "compact ((\<lambda>x. exp (- (x *\<^sub>R s))) ` {a .. b})"
    by (rule compact_continuous_image) (auto intro!: continuous_intros)
  then obtain C where C: "0 \<le> C" "a \<le> x \<Longrightarrow> x \<le> b \<Longrightarrow> cmod (exp (- (x *\<^sub>R s))) \<le> C" for x
    using 1
    apply (auto simp: bounded_iff dest!: compact_imp_bounded)
    by (metis atLeastAtMost_iff exp_ge_zero order_refl order_trans scaleR_complex.sel(1))

  have m: "(\<lambda>x. indicator {a..b} x *\<^sub>R f x) \<in> borel_measurable lebesgue"
    apply (rule has_integral_implies_lebesgue_measurable)
    apply (rule integrable_integral)
    apply (rule that)
    done
  have "complex_set_integrable lebesgue {a..b} (\<lambda>x. exp (- (x *\<^sub>R s)) * (indicator {a .. b} x *\<^sub>R f x))"
    unfolding set_integrable_def
    apply (rule integrableI_bounded_set_indicator[where B="C * B"])
       apply (simp; fail)
      apply (rule borel_measurable_times)
       apply measurable
        apply (simp add: measurable_completion)
       apply (simp add: measurable_completion)
      apply (rule m)
    apply (simp add: emeasure_lborel_Icc_eq)
    using that(1)
    apply eventually_elim
    apply (auto simp: norm_mult)
    apply (rule mult_mono)
    using C
    by auto
  then show ?case
    unfolding set_integrable_def
    by (simp add: laplace_integrand_def[abs_def] indicator_inter_arith[symmetric])
qed

lemma laplace_integrand_integrable_on_Icc:
  "laplace_integrand s integrable_on {a..b}"
  if "AE x\<in>{a..b} in lebesgue. cmod (f x) \<le> B" "f integrable_on {a..b}"
  using laplace_integrand_absolutely_integrable_on_Icc[OF that]
  using set_lebesgue_integral_eq_integral(1) by blast

lemma
  assumes eo: "exponential_order M c f"
    and cs: "c < Re s"
  shows laplace_integrand_integrable_on_Ici_iff:
    "laplace_integrand s integrable_on {a..} \<longleftrightarrow>
      (\<forall>k>a. laplace_integrand s integrable_on {a..k})"
    (is ?th1)
  and laplace_integrand_absolutely_integrable_on_Ici_iff:
    "laplace_integrand s absolutely_integrable_on {a..} \<longleftrightarrow>
      (\<forall>k>a. laplace_integrand s absolutely_integrable_on {a..k})"
    (is ?th2)
proof -
  have "\<forall>\<^sub>F t in at_top. a < (t::real)"
    using eventually_gt_at_top by blast
  then have "\<forall>\<^sub>F t in at_top. t > a \<and> cmod (laplace_integrand s t) \<le> M * exp (- (Re s - c) * t)"
    using eventually_laplace_integrand_le[OF eo]
    by eventually_elim (auto)
  then obtain A where A: "A > a" and le: "t \<ge> A \<Longrightarrow> cmod (laplace_integrand s t) \<le> M * exp (- (Re s - c) * t)" for t
    unfolding eventually_at_top_linorder
    by blast

  let ?f = "\<lambda>(k::real) (t::real). indicat_real {A..k} t *\<^sub>R laplace_integrand s t"

  from exponential_orderD[OF eo] have "M \<noteq> 0" by simp
  have 2: "(\<lambda>t. M * exp (- (Re s - c) * t)) integrable_on {A..}"
    unfolding integrable_on_cmult_iff[OF \<open>M \<noteq> 0\<close>] norm_exp_eq_Re
    by (rule integrable_on_exp_minus_to_infinity) (simp add: cs)

  have 3: "t\<in>{A..} \<Longrightarrow> cmod (?f k t) \<le> M * exp (- (Re s - c) * t)"
    (is "t\<in>_\<Longrightarrow> ?lhs t \<le> ?rhs t")
    for t k
  proof safe
    fix t assume "A \<le> t"
    have "?lhs t \<le> cmod (laplace_integrand s t)"
      by (auto simp: indicator_def)
    also have "\<dots> \<le> ?rhs t" using \<open>A \<le> t\<close> le by (simp add: laplace_integrand_def)
    finally show "?lhs t \<le> ?rhs t" .
  qed

  have 4: "\<forall>t\<in>{A..}. ((\<lambda>k. ?f k t) \<longlongrightarrow> laplace_integrand s t) at_top"
  proof safe
    fix t assume t: "t \<ge> A"
    have "\<forall>\<^sub>F k in at_top. k \<ge> t"
      by (simp add: eventually_ge_at_top)
    then have "\<forall>\<^sub>F k in at_top. laplace_integrand s t = ?f k t"
      by eventually_elim (use t in \<open>auto simp: indicator_def\<close>)
    then show "((\<lambda>k. ?f k t) \<longlongrightarrow> laplace_integrand s t) at_top" using tendsto_const
      by (rule Lim_transform_eventually[rotated])
  qed

  show th1: ?th1
  proof safe
    assume "\<forall>k>a. laplace_integrand s integrable_on {a..k}"
    note li = this[rule_format]
    have liA: "laplace_integrand s integrable_on {A..k}" for k
    proof cases
      assume "k \<le> A"
      then have "{A..k} = (if A = k then {k} else {})" by auto
      then show ?thesis by (auto intro!: integrable_negligible)
    next
      assume n: "\<not> k \<le> A"
      show ?thesis
        by (rule integrable_on_subinterval[OF li[of k]]) (use A n in auto)
    qed
    have "?f k integrable_on {A..k}" for k
      using liA[of k] negligible_empty
      by (rule integrable_spike) auto
    then have 1: "?f k integrable_on {A..}" for k
      by (rule integrable_on_superset) auto
    note 1 2 3 4
    note * = this[unfolded set_integrable_def]
    from li[of A] dominated_convergence_at_top(1)[OF *]
    show "laplace_integrand s integrable_on {a..}"
      by (rule integrable_Un') (use \<open>a < A\<close> in \<open>auto simp: max_def li\<close>)
  qed (rule integrable_on_subinterval, assumption, auto)

  show ?th2
  proof safe
    assume ai: "\<forall>k>a. laplace_integrand s absolutely_integrable_on {a..k}"
    then have "laplace_integrand s absolutely_integrable_on {a..A}"
      using A by auto
    moreover
    from ai have "\<forall>k>a. laplace_integrand s integrable_on {a..k}"
      using set_lebesgue_integral_eq_integral(1) by blast
    with th1 have i: "laplace_integrand s integrable_on {a..}" by auto
    have 1: "?f k integrable_on {A..}" for k
      apply (rule integrable_on_superset[where S="{A..k}"])
      using _ negligible_empty
        apply (rule integrable_spike[where f="laplace_integrand s"])
        apply (rule integrable_on_subinterval)
         apply (rule i)
      by (use \<open>a < A\<close> in auto)
    have "laplace_integrand s absolutely_integrable_on {A..}"
      using _ dominated_convergence_at_top(1)[OF 1 2 3 4] 2
      by (rule absolutely_integrable_integrable_bound) (use le in auto)
    ultimately
    have "laplace_integrand s absolutely_integrable_on ({a..A} \<union> {A..})"
      by (rule set_integrable_Un) auto
    also have "{a..A} \<union> {A..} = {a..}" using \<open>a < A\<close> by auto
    finally show "local.laplace_integrand s absolutely_integrable_on {a..}" .
  qed (rule set_integrable_subset, assumption, auto)
qed

theorem laplace_exists_laplace_integrandI:
  assumes "laplace_integrand s integrable_on {0..}"
  obtains F where "(f has_laplace F) s"
proof -
  from assms
  have "(f has_laplace integral {0..} (laplace_integrand s)) s"
    unfolding has_laplace_def laplace_integrand_def by blast
  thus ?thesis ..
qed

lemma
  assumes eo: "exponential_order M c f"
    and pc: "\<And>k. AE x\<in>{0..k} in lebesgue. cmod (f x) \<le> B k" "\<And>k. f integrable_on {0..k}"
    and s: "Re s > c"
  shows laplace_integrand_integrable: "laplace_integrand s integrable_on {0..}" (is ?th1)
    and laplace_integrand_absolutely_integrable:
      "laplace_integrand s absolutely_integrable_on {0..}" (is ?th2)
  using eo laplace_integrand_absolutely_integrable_on_Icc[OF pc] s
  by (auto simp: laplace_integrand_integrable_on_Ici_iff
      laplace_integrand_absolutely_integrable_on_Ici_iff
      set_lebesgue_integral_eq_integral)

lemma piecewise_continuous_on_AE_boundedE:
  assumes pc: "\<And>k. piecewise_continuous_on a k (I k) f"
  obtains B where "\<And>k. AE x\<in>{a..k} in lebesgue. cmod (f x) \<le> B k"
  apply atomize_elim
  apply (rule choice)
  apply (rule allI)
  subgoal for k
    using bounded_piecewise_continuous_image[OF pc[of k]]
    by (force simp: bounded_iff)
  done

theorem piecewise_continuous_on_has_laplace:
  assumes eo: "exponential_order M c f"
    and pc: "\<And>k. piecewise_continuous_on 0 k (I k) f"
    and s: "Re s > c"
  obtains F where "(f has_laplace F) s"
proof -
  from piecewise_continuous_on_AE_boundedE[OF pc]
  obtain B where AE: "AE x\<in>{0..k} in lebesgue. cmod (f x) \<le> B k" for k by force
  have int: "f integrable_on {0..k}" for k
    using pc
    by (rule piecewise_continuous_on_integrable)
  show ?thesis
    using pc
    apply (rule piecewise_continuous_on_AE_boundedE)
    apply (rule laplace_exists_laplace_integrandI)
     apply (rule laplace_integrand_integrable)
        apply (rule eo)
       apply assumption
      apply (rule int)
     apply (rule s)
    by (rule that)
qed

end

subsection \<open>Concrete Laplace Transforms\<close>

lemma exp_scaleR_has_vector_derivative_left'[derivative_intros]:
  "((\<lambda>t. exp (t *\<^sub>R A)) has_vector_derivative A * exp (t *\<^sub>R A)) (at t within S)"
  by (metis exp_scaleR_has_vector_derivative_right exp_times_scaleR_commute)

lemma
  fixes a::complex\<comment>\<open>TODO: generalize\<close>
  assumes a: "0 < Re a"
  shows integrable_on_cexp_minus_to_infinity: "(\<lambda>x. exp (x *\<^sub>R - a)) integrable_on {c..}"
    and integral_cexp_minus_to_infinity:  "integral {c..} (\<lambda>x. exp (x *\<^sub>R - a)) = exp (c *\<^sub>R - a) / a"
proof -
  from a have "a \<noteq> 0" by auto
  define f where "f = (\<lambda>k x. if x \<in> {c..real k} then exp (x *\<^sub>R -a) else 0)"
  {
    fix k :: nat assume k: "of_nat k \<ge> c"
    from \<open>a \<noteq> 0\<close> k
      have "((\<lambda>x. exp (x *\<^sub>R -a)) has_integral (-exp (k *\<^sub>R -a)/a - (-exp (c *\<^sub>R -a)/a))) {c..real k}"
      by (intro fundamental_theorem_of_calculus)
         (auto intro!: derivative_eq_intros exp_scaleR_has_vector_derivative_left
            simp: divide_inverse_commute
               simp del: scaleR_minus_left scaleR_minus_right)
    hence "(f k has_integral (exp (c *\<^sub>R -a)/a - exp (k *\<^sub>R -a)/a)) {c..}" unfolding f_def
      by (subst has_integral_restrict) simp_all
  } note has_integral_f = this

  have integrable_fk: "f k integrable_on {c..}" for k
  proof -
    have "(\<lambda>x. exp (x *\<^sub>R -a)) integrable_on {c..of_real k}" (is ?P)
      unfolding f_def by (auto intro!: continuous_intros integrable_continuous_real)
    then have int: "(f k) integrable_on {c..of_real k}"
      by (rule integrable_eq) (simp add: f_def)
    show ?thesis
      by (rule integrable_on_superset[OF int]) (auto simp: f_def)
  qed
  have limseq: "\<And>x. x \<in>{c..} \<Longrightarrow> (\<lambda>k. f k x) \<longlonglongrightarrow> exp (x *\<^sub>R - a)"
    apply (auto intro!: Lim_transform_eventually[OF tendsto_const] simp: f_def)
    by (meson eventually_sequentiallyI nat_ceiling_le_eq)
  have bnd: "\<And>x. x \<in> {c..} \<Longrightarrow> cmod (f k x) \<le> exp (- Re a * x)" for k
    by (auto simp: f_def)

  have [simp]: "f k = (\<lambda>_. 0)" if "of_nat k < c" for k using that by (auto simp: fun_eq_iff f_def)
  have integral_f: "integral {c..} (f k) =
                      (if real k \<ge> c then exp (c *\<^sub>R -a)/a - exp (k *\<^sub>R -a)/a else 0)"
    for k using integral_unique[OF has_integral_f[of k]] by simp

  have "(\<lambda>k. exp (c *\<^sub>R -a)/a - exp (k *\<^sub>R -a)/a) \<longlonglongrightarrow> exp (c*\<^sub>R-a)/a - 0/a"
    apply (intro tendsto_intros filterlim_compose[OF exp_at_bot]
          filterlim_tendsto_neg_mult_at_bot[OF tendsto_const] filterlim_real_sequentially)+
     apply (rule tendsto_norm_zero_cancel)
    by (auto intro!: assms \<open>a \<noteq> 0\<close> filterlim_real_sequentially
        filterlim_compose[OF exp_at_bot] filterlim_compose[OF filterlim_uminus_at_bot_at_top]
        filterlim_at_top_mult_tendsto_pos[OF tendsto_const])
  moreover
  note A = dominated_convergence[where g="\<lambda>x. exp (x *\<^sub>R -a)",
    OF integrable_fk integrable_on_exp_minus_to_infinity[where a="Re a" and c=c, OF \<open>0 < Re a\<close>]
      bnd limseq]
  from A(1) show "(\<lambda>x. exp (x *\<^sub>R - a)) integrable_on {c..}" .
  from eventually_gt_at_top[of "nat \<lceil>c\<rceil>"] have "eventually (\<lambda>k. of_nat k > c) sequentially"
    by eventually_elim linarith
  hence "eventually (\<lambda>k. exp (c *\<^sub>R -a)/a - exp (k *\<^sub>R -a)/a = integral {c..} (f k)) sequentially"
    by eventually_elim (simp add: integral_f)
  ultimately have "(\<lambda>k. integral {c..} (f k)) \<longlonglongrightarrow> exp (c *\<^sub>R -a)/a - 0/a"
    by (rule Lim_transform_eventually)
  from LIMSEQ_unique[OF A(2) this]
  show "integral {c..} (\<lambda>x. exp (x *\<^sub>R -a)) = exp (c *\<^sub>R -a)/a" by simp
qed

lemma has_integral_cexp_minus_to_infinity:
  fixes a::complex\<comment>\<open>TODO: generalize\<close>
  assumes a: "0 < Re a"
  shows "((\<lambda>x. exp (x *\<^sub>R - a)) has_integral exp (c *\<^sub>R - a) / a) {c..}"
  using integral_cexp_minus_to_infinity[OF assms]
    integrable_on_cexp_minus_to_infinity[OF assms]
  using has_integral_integrable_integral by blast

lemma has_laplace_one:
  "((\<lambda>_. 1) has_laplace inverse s) s" if "Re s > 0"
proof (safe intro!: has_laplaceI)
  from that have "((\<lambda>t. exp (t *\<^sub>R - s)) has_integral inverse s) {0..}"
    by (rule has_integral_cexp_minus_to_infinity[THEN has_integral_eq_rhs])
       (auto simp: inverse_eq_divide)
  then show "((\<lambda>t. exp (t *\<^sub>R - s) * 1) has_integral inverse s) {0..}" by simp
qed

lemma has_laplace_add:
  assumes f: "(f has_laplace F) S"
  assumes g: "(g has_laplace G) S"
  shows "((\<lambda>x. f x + g x) has_laplace F + G) S"
  apply (rule has_laplaceI)
  using has_integral_add[OF has_laplaceD[OF f ] has_laplaceD[OF g]]
  by (auto simp: algebra_simps)

lemma has_laplace_cmul:
  assumes "(f has_laplace F) S"
  shows "((\<lambda>x. r *\<^sub>R f x) has_laplace r *\<^sub>R F) S"
  apply (rule has_laplaceI)
  using has_laplaceD[OF assms, THEN has_integral_cmul[where c=r]]
  by auto

lemma has_laplace_uminus:
  assumes "(f has_laplace F) S"
  shows "((\<lambda>x. - f x) has_laplace - F) S"
  using has_laplace_cmul[OF assms, of "-1"]
  by auto

lemma has_laplace_minus:
  assumes f: "(f has_laplace F) S"
  assumes g: "(g has_laplace G) S"
  shows "((\<lambda>x. f x - g x) has_laplace F - G) S"
  using has_laplace_add[OF f has_laplace_uminus[OF g]]
  by simp

lemma has_laplace_spike:
  "(f has_laplace L) s"
  if L: "(g has_laplace L) s"
    and "negligible T"
    and "\<And>t. t \<notin> T \<Longrightarrow> t \<ge> 0 \<Longrightarrow> f t = g t"
  by (auto intro!: has_laplaceI has_integral_spike[where S="T", OF _ _ has_laplaceD[OF L]] that)

lemma has_laplace_frequency_shift:\<comment>\<open>First Translation Theorem in Schiff\<close>
  "((\<lambda>t. exp (t *\<^sub>R b) * f t) has_laplace L) s"
  if "(f has_laplace L) (s - b)"
  using that
  by (auto intro!: has_laplaceI dest!: has_laplaceD
      simp: mult_exp_exp algebra_simps)

theorem has_laplace_derivative_time_domain:
  "(f' has_laplace s * L - f0) s"
  if L: "(f has_laplace L) s"
    and f': "\<And>t. t > 0 \<Longrightarrow> (f has_vector_derivative f' t) (at t)"
    and f0: "(f \<longlongrightarrow> f0) (at_right 0)"
    and eo: "exponential_order M c f"
    and cs: "c < Re s"
    \<comment>\<open>Proof and statement follow "The Laplace Transform: Theory and Applications" by Joel L. Schiff.\<close>
proof (rule has_laplaceI)
  have ce: "continuous_on S (\<lambda>t. exp (t *\<^sub>R - s))" for S
    by (auto intro!: continuous_intros)
  have de: "((\<lambda>t. exp (t *\<^sub>R - s)) has_vector_derivative (- s * exp (- (t *\<^sub>R s)))) (at t)" for t
    by (auto simp: has_vector_derivative_def intro!: derivative_eq_intros ext)
  have "((\<lambda>x. -s * (f x * exp (- (x *\<^sub>R s)))) has_integral - s * L) {0..}"
    apply (rule has_integral_mult_right)
    using has_laplaceD[OF L]
    by (auto simp: ac_simps)

  define g where "g x = (if x \<le> 0 then f0 else f x)" for x

  have eog: "exponential_order M c g"
  proof -
    from exponential_orderD[OF eo] have "0 < M"
      and ev: "\<forall>\<^sub>F t in at_top. cmod (f t) \<le> M * exp (c * t)" .
    have "\<forall>\<^sub>F t::real in at_top. t > 0" by simp
    with ev have "\<forall>\<^sub>F t in at_top. cmod (g t) \<le> M * exp (c * t)"
      by eventually_elim (auto simp: g_def)
    with \<open>0 < M\<close> show ?thesis
      by (rule exponential_orderI)
  qed
  have Lg: "(g has_laplace L) s"
    using L
    by (rule has_laplace_spike[where T="{0}"]) (auto simp: g_def)
  have g': "\<And>t. 0 < t \<Longrightarrow> (g has_vector_derivative f' t) (at t)"
    using f'
    by (rule has_vector_derivative_transform_within_open[where S="{0<..}"]) (auto simp: g_def)
  have cg: "continuous_on {0..k} g" for k
    apply (auto simp: g_def continuous_on_def)
     apply (rule filterlim_at_within_If)
    subgoal by (rule tendsto_intros)
    subgoal
      apply (rule tendsto_within_subset)
       apply (rule f0)
      by auto
    subgoal premises prems for x
    proof -
      from prems have "0 < x" by auto
      from order_tendstoD[OF tendsto_ident_at this]
      have "eventually ((<) 0) (at x within {0..k})" by auto
      then have "\<forall>\<^sub>F x in at x within {0..k}. f x = (if x \<le> 0 then f0 else f x)"
        by eventually_elim auto
      moreover
      note [simp] = at_within_open[where S="{0<..}"]
      have "continuous_on {0<..} f"
        by (rule continuous_on_vector_derivative)
          (auto simp add: intro!: f')
      then have "(f \<longlongrightarrow> f x) (at x within {0..k})"
        using \<open>0 < x\<close>
        by (auto simp: continuous_on_def intro: Lim_at_imp_Lim_at_within)
      ultimately show ?thesis
        by (rule Lim_transform_eventually[rotated])
    qed
    done
  then have pcg: "piecewise_continuous_on 0 k {} g" for k
    by (auto simp: piecewise_continuous_on_def)
  from piecewise_continuous_on_AE_boundedE[OF this]
  obtain B where B: "AE x\<in>{0..k} in lebesgue. cmod (g x) \<le> B k" for k by auto
  have 1: "laplace_integrand g s absolutely_integrable_on {0..}"
    apply (rule laplace_integrand_absolutely_integrable[OF eog])
      apply (rule B)
     apply (rule piecewise_continuous_on_integrable)
     apply (rule pcg)
    apply (rule cs)
    done
  then have csi: "complex_set_integrable lebesgue {0..} (\<lambda>x. exp (x *\<^sub>R - s) * g x)"
    by (auto simp: laplace_integrand_def[abs_def])
  from has_laplaceD[OF Lg, THEN has_integral_improperE, OF csi]
  obtain J where J: "\<And>k. ((\<lambda>t. exp (t *\<^sub>R - s) * g t) has_integral J k) {0..k}"
    and [tendsto_intros]: "(J \<longlongrightarrow> L) at_top"
    by auto
  have "((\<lambda>x. -s * (exp (x *\<^sub>R - s) * g x)) has_integral -s * J k) {0..k}" for k
    by (rule has_integral_mult_right) (rule J)
  then have *: "((\<lambda>x. g x * (- s * exp (- (x *\<^sub>R s)))) has_integral -s * J k) {0..k}" for k
    by (auto simp: algebra_simps)
  have "\<forall>\<^sub>F k::real in at_top. k \<ge> 0"
    using eventually_ge_at_top by blast
  then have evI: "\<forall>\<^sub>F k in at_top. ((\<lambda>t. exp (t *\<^sub>R - s) * f' t) has_integral
    g k * exp (k *\<^sub>R - s) + s * J k - g 0) {0..k}"
  proof eventually_elim
    case (elim k)
    show ?case
      apply (subst mult.commute)
      apply (rule integration_by_parts_interior[OF bounded_bilinear_mult], fact)
      apply (rule cg) apply (rule ce) apply (rule g') apply force apply (rule de)
      apply (rule has_integral_eq_rhs)
       apply (rule *)
      by (auto simp: )
  qed
  have t1: "((\<lambda>x. g x * exp (x *\<^sub>R - s)) \<longlongrightarrow> 0) at_top"
    apply (subst mult.commute)
    unfolding laplace_integrand_def[symmetric]
    apply (rule Lim_null_comparison)
    apply (rule eventually_laplace_integrand_le[OF eog])
    apply (rule tendsto_mult_right_zero)
    apply (rule filterlim_compose[OF exp_at_bot])
    apply (rule filterlim_tendsto_neg_mult_at_bot)
      apply (rule tendsto_intros)
    using cs apply simp
    apply (rule filterlim_ident)
    done
  show "((\<lambda>t. exp (t *\<^sub>R - s) * f' t) has_integral s * L - f0) {0..}"
    apply (rule has_integral_improper_at_topI[OF evI])
    subgoal
      apply (rule tendsto_eq_intros)
       apply (rule tendsto_intros)
        apply (rule t1)
       apply (rule tendsto_intros)
        apply (rule tendsto_intros)
       apply (rule tendsto_intros)
       apply (rule tendsto_intros)
      by (simp add: g_def)
    done
qed

lemma exp_times_has_integral:
  "((\<lambda>t. exp (c * t)) has_integral (if c = 0 then t else exp (c * t) / c) - (if c = 0 then t0 else exp (c * t0) / c)) {t0 .. t}"
  if "t0 \<le> t"
  for c t::real
  apply (cases "c = 0")
  subgoal
    using that
    apply auto
    apply (rule has_integral_eq_rhs)
     apply (rule has_integral_const_real)
    by auto
  subgoal
    apply (rule fundamental_theorem_of_calculus)
    using that
    by (auto simp: has_vector_derivative_def intro!: derivative_eq_intros)
  done

lemma integral_exp_times:
  "integral {t0 .. t} (\<lambda>t. exp (c * t)) = (if c = 0 then t - t0 else exp (c * t) / c - exp (c * t0) / c)"
  if "t0 \<le> t"
  for c t::real
  using exp_times_has_integral[OF that, of c] that
  by (auto split: if_splits)

lemma filtermap_times_pos_at_top: "filtermap ((*) e) at_top = at_top"
  if "e > 0"
  for e::real
  apply (rule filtermap_fun_inverse[of "(*) (inverse e)"])
    apply (rule filterlim_tendsto_pos_mult_at_top)
      apply (rule tendsto_intros)
  subgoal using that by simp
    apply (rule filterlim_ident)
    apply (rule filterlim_tendsto_pos_mult_at_top)
      apply (rule tendsto_intros)
  subgoal using that by simp
   apply (rule filterlim_ident)
  using that by auto

lemma exponential_order_additiveI:
  assumes "0 < M" and eo: "\<forall>\<^sub>F t in at_top. norm (f t) \<le> K + M * exp (c * t)" and "c \<ge> 0"
  obtains M' where "exponential_order M' c f"
proof -
  consider "c = 0" | "c > 0" using \<open>c \<ge> 0\<close> by arith
  then show ?thesis
  proof cases
    assume "c = 0"
    have "exponential_order (max K 0 + M) c f"
      using eo
       apply (auto intro!: exponential_orderI add_nonneg_pos \<open>0 < M\<close> simp: \<open>c = 0\<close>)
      apply (auto simp: max_def)
      using eventually_elim2 by force
    then show ?thesis ..
  next
    assume "c > 0"
    have "\<forall>\<^sub>F t in at_top. norm (f t) \<le> K + M * exp (c * t)"
      by fact
    moreover
    have "\<forall>\<^sub>F t in (filtermap exp (filtermap ((*) c) at_top)). K < t"
      by (simp add: filtermap_times_pos_at_top \<open>c > 0\<close> filtermap_exp_at_top)
    then have "\<forall>\<^sub>F t in at_top. K < exp (c * t)"
      by (simp add: eventually_filtermap)
    ultimately
    have "\<forall>\<^sub>F t in at_top. norm (f t) \<le> (1 + M) * exp (c * t)"
      by eventually_elim (auto simp: algebra_simps)
    with add_nonneg_pos[OF zero_le_one \<open>0 < M\<close>]
    have "exponential_order (1 + M) c f"
      by (rule exponential_orderI)
    then show ?thesis ..
  qed
qed

lemma exponential_order_integral:
  fixes f::"real \<Rightarrow> 'a::banach"
  assumes I: "\<And>t. t \<ge> a \<Longrightarrow> (f has_integral I t) {a .. t}"
    and eo: "exponential_order M c f"
    and "c > 0"
  obtains M' where "exponential_order M' c I"
proof -
  from exponential_orderD[OF eo] have "0 < M"
    and bound: "\<forall>\<^sub>F t in at_top. norm (f t) \<le> M * exp (c * t)"
    by auto
  have "\<forall>\<^sub>F t in at_top. t > a"
    by simp
  from bound this
  have "\<forall>\<^sub>F t in at_top. norm (f t) \<le> M * exp (c * t) \<and> t > a"
    by eventually_elim auto
  then obtain t0 where t0: "\<And>t. t \<ge> t0 \<Longrightarrow> norm (f t) \<le> M * exp (c * t)" "t0 > a"
    by (auto simp: eventually_at_top_linorder)
  have "\<forall>\<^sub>F t in at_top. t > t0" by simp
  then have "\<forall>\<^sub>F t in at_top. norm (I t) \<le> norm (integral {a..t0} f) - M * exp (c * t0) / c + (M / c) * exp (c * t)"
  proof eventually_elim
    case (elim t) then have that: "t \<ge> t0" by simp
    from t0 have "a \<le> t0" by simp
    have "f integrable_on {a .. t0}" "f integrable_on {t0 .. t}"
      subgoal by (rule has_integral_integrable[OF I[OF \<open>a \<le> t0\<close>]])
      subgoal
        apply (rule integrable_on_subinterval[OF has_integral_integrable[OF I[where t=t]]])
        using \<open>t0 > a\<close> that by auto
      done
    have "I t = integral {a .. t0} f + integral {t0 .. t} f"
      by (smt I \<open>a \<le> t0\<close> \<open>f integrable_on {t0..t}\<close> has_integral_combine has_integral_integrable_integral that)
    also have "norm \<dots> \<le> norm (integral {a .. t0} f) + norm (integral {t0 .. t} f)" by norm
    also
    have "norm (integral {t0 .. t} f) \<le> integral {t0 .. t} (\<lambda>t. M * exp (c * t))"
      apply (rule integral_norm_bound_integral)
        apply fact
      by (auto intro!: integrable_continuous_interval continuous_intros t0)
    also have "\<dots> = M * integral {t0 .. t} (\<lambda>t. exp (c * t))"
      by simp
    also have "integral {t0 .. t} (\<lambda>t. exp (c * t)) = exp (c * t) / c - exp (c * t0) / c"
      using \<open>c > 0\<close> \<open>t0 \<le> t\<close>
      by (subst integral_exp_times) auto
    finally show ?case
      using \<open>c > 0\<close>
      by (auto simp: algebra_simps)
  qed
  from exponential_order_additiveI[OF divide_pos_pos[OF \<open>0 < M\<close> \<open>0 < c\<close>] this less_imp_le[OF \<open>0 < c\<close>]]
  obtain M' where "exponential_order M' c I" .
  then show ?thesis ..
qed

lemma integral_has_vector_derivative_piecewise_continuous:
  fixes f :: "real \<Rightarrow> 'a::euclidean_space"\<comment>\<open>TODO: generalize?\<close>
  assumes "piecewise_continuous_on a b D f"
  shows "\<And>x. x \<in> {a .. b} - D \<Longrightarrow>
    ((\<lambda>u. integral {a..u} f) has_vector_derivative f(x)) (at x within {a..b} - D)"
  using assms
proof (induction a b D f rule: piecewise_continuous_on_induct)
  case (empty a b f)
  then show ?case
    by (auto intro: integral_has_vector_derivative)
next
  case (combine a i b I f1 f2 f)
  then consider "x < i" | "i < x" by auto arith

  then show ?case
  proof cases\<comment>\<open>TODO: this is very explicit...\<close>
    case 1
    have evless: "\<forall>\<^sub>F xa in nhds x. xa < i"
      apply (rule order_tendstoD[OF _ \<open>x < i\<close>])
      by (simp add: filterlim_ident)
    have eq: "at x within {a..b} - insert i I = at x within {a .. i} - I"
      unfolding filter_eq_iff
    proof safe
      fix P
      assume "eventually P (at x within {a..i} - I)"
      with evless show "eventually P (at x within {a..b} - insert i I)"
        unfolding eventually_at_filter
        by eventually_elim auto
    next
      fix P
      assume "eventually P (at x within {a..b} - insert i I)"
      with evless show "eventually P (at x within {a..i} - I)"
        unfolding eventually_at_filter
        apply eventually_elim
        using 1 combine
        by auto
    qed
    have "f x = f1 x" using combine 1 by auto
    have i_eq: "integral {a..y} f = integral {a..y} f1" if "y < i" for y
      using negligible_empty
      apply (rule integral_spike)
      using combine 1 that
      by auto
    from evless have ev_eq: "\<forall>\<^sub>F x in nhds x. x \<in> {a..i} - I \<longrightarrow> integral {a..x} f = integral {a..x} f1"
      by eventually_elim (auto simp: i_eq)
    show ?thesis unfolding eq \<open>f x = f1 x\<close>
      apply (subst has_vector_derivative_cong_ev[OF ev_eq])
      using combine.IH[of x]
      using combine.hyps combine.prems 1
      by (auto simp: i_eq)
  next
    case 2
    have evless: "\<forall>\<^sub>F xa in nhds x. xa > i"
      apply (rule order_tendstoD[OF _ \<open>x > i\<close>])
      by (simp add: filterlim_ident)
    have eq: "at x within {a..b} - insert i I = at x within {i .. b} - I"
      unfolding filter_eq_iff
    proof safe
      fix P
      assume "eventually P (at x within {i..b} - I)"
      with evless show "eventually P (at x within {a..b} - insert i I)"
        unfolding eventually_at_filter
        by eventually_elim auto
    next
      fix P
      assume "eventually P (at x within {a..b} - insert i I)"
      with evless show "eventually P (at x within {i..b} - I)"
        unfolding eventually_at_filter
        apply eventually_elim
        using 2 combine
        by auto
    qed
    have "f x = f2 x" using combine 2 by auto
    have i_eq: "integral {a..y} f = integral {a..i} f + integral {i..y} f2" if "i < y" "y \<le> b" for y
    proof -
      have "integral {a..y} f = integral {a..i} f + integral {i..y} f"
        apply (cases "i = y")
        subgoal by auto
        subgoal
          apply (rule Henstock_Kurzweil_Integration.integral_combine[symmetric])
          using combine that apply auto
          apply (rule integrable_Un'[where A="{a .. i}" and B="{i..y}"])
          subgoal
            by (rule integrable_spike[where S="{i}" and f="f1"])
              (auto intro: piecewise_continuous_on_integrable)
          subgoal
            apply (rule integrable_on_subinterval[where S="{i..b}"])
            by (rule integrable_spike[where S="{i}" and f="f2"])
              (auto intro: piecewise_continuous_on_integrable)
          subgoal by (auto simp: max_def min_def)
          subgoal by auto
          done
        done
      also have "integral {i..y} f = integral {i..y} f2"
        apply (rule integral_spike[where S="{i}"])
        using combine 2 that
        by auto
      finally show ?thesis .
    qed
    from evless have ev_eq: "\<forall>\<^sub>F y in nhds x. y \<in> {i..b} - I \<longrightarrow> integral {a..y} f = integral {a..i} f + integral {i..y} f2"
      by eventually_elim (auto simp: i_eq)
    show ?thesis unfolding eq
      apply (subst has_vector_derivative_cong_ev[OF ev_eq])
      using combine.IH[of x] combine.prems combine.hyps 2
      by (auto simp: i_eq intro!: derivative_eq_intros)
  qed
qed (auto intro: has_vector_derivative_within_subset)

lemma has_derivative_at_split:
  "(f has_derivative f') (at x) \<longleftrightarrow> (f has_derivative f') (at_left x) \<and> (f has_derivative f') (at_right x)"
  for x::"'a::{linorder_topology, real_normed_vector}"
  by (auto simp: has_derivative_at_within filterlim_at_split)

lemma has_vector_derivative_at_split:
  "(f has_vector_derivative f') (at x) \<longleftrightarrow>
   (f has_vector_derivative f') (at_left x) \<and>
   (f has_vector_derivative f') (at_right x)"
  using has_derivative_at_split[of f "\<lambda>h. h *\<^sub>R f'" x]
  by (simp add: has_vector_derivative_def)

lemmas differentiableI_vector[intro]

lemma differentiable_at_splitD:
  "f differentiable at_left x"
  "f differentiable at_right x"
  if "f differentiable (at x)"
  for x::real
  using that[unfolded vector_derivative_works has_vector_derivative_at_split]
  by auto

lemma integral_differentiable:
  fixes f :: "real \<Rightarrow> 'a::banach"
  assumes "continuous_on {a..b} f"
    and "x \<in> {a..b}"
  shows "(\<lambda>u. integral {a..u} f) differentiable at x within {a..b}"
  using integral_has_vector_derivative[OF assms]
  by blast

theorem integral_has_vector_derivative_piecewise_continuous':
  fixes f :: "real \<Rightarrow> 'a::euclidean_space"\<comment>\<open>TODO: generalize?\<close>
  assumes "piecewise_continuous_on a b D f" "a < b"
  shows
    "(\<forall>x. a < x \<longrightarrow> x < b \<longrightarrow> x \<notin> D \<longrightarrow> (\<lambda>u. integral {a..u} f) differentiable at x) \<and>
    (\<forall>x. a \<le> x \<longrightarrow> x < b \<longrightarrow> (\<lambda>t. integral {a..t} f) differentiable at_right x) \<and>
    (\<forall>x. a < x \<longrightarrow> x \<le> b \<longrightarrow> (\<lambda>t. integral {a..t} f) differentiable at_left x)"
  using assms
proof (induction a b D f rule: piecewise_continuous_on_induct)
  case (empty a b f)
  have "a < x \<Longrightarrow> x < b \<Longrightarrow> (\<lambda>u. integral {a..u} f) differentiable (at x)" for x
    using integral_differentiable[OF empty(1), of x]
    by (auto simp: at_within_interior)
  then show ?case
    using integral_differentiable[OF empty(1), of a]
      integral_differentiable[OF empty(1), of b]
      \<open>a < b\<close>
    by (auto simp: at_within_Icc_at_right at_within_Icc_at_left le_less
        intro: differentiable_at_withinI)
next
  case (combine a i b I f1 f2 f)
  from \<open>piecewise_continuous_on a i I f1\<close> have "finite I"
    by (auto elim!: piecewise_continuous_onE)

  from combine(4) have "piecewise_continuous_on a i (insert i I) f1"
    by (rule piecewise_continuous_on_insert_rightI)
  then have "piecewise_continuous_on a i (insert i I) f"
    by (rule piecewise_continuous_on_congI) (auto simp: combine)
  moreover
  from combine(5) have "piecewise_continuous_on i b (insert i I) f2"
    by (rule piecewise_continuous_on_insert_leftI)
  then have "piecewise_continuous_on i b (insert i I) f"
    by (rule piecewise_continuous_on_congI) (auto simp: combine)
  ultimately have "piecewise_continuous_on a b (insert i I) f"
    by (rule piecewise_continuous_on_combine)
  then have f_int: "f integrable_on {a .. b}"
    by (rule piecewise_continuous_on_integrable)

  from combine.IH
  have f1: "x>a \<Longrightarrow> x < i \<Longrightarrow> x \<notin> I \<Longrightarrow> (\<lambda>u. integral {a..u} f1) differentiable (at x)"
    "x\<ge>a \<Longrightarrow> x < i \<Longrightarrow> (\<lambda>t. integral {a..t} f1) differentiable (at_right x)"
    "x>a \<Longrightarrow> x \<le> i \<Longrightarrow> (\<lambda>t. integral {a..t} f1) differentiable (at_left x)"
   and f2: "x>i \<Longrightarrow> x < b \<Longrightarrow> x \<notin> I \<Longrightarrow> (\<lambda>u. integral {i..u} f2) differentiable (at x)"
    "x\<ge>i \<Longrightarrow> x < b \<Longrightarrow> (\<lambda>t. integral {i..t} f2) differentiable (at_right x)"
    "x>i \<Longrightarrow> x \<le> b \<Longrightarrow> (\<lambda>t. integral {i..t} f2) differentiable (at_left x)"
    for x
    by auto

  have "(\<lambda>u. integral {a..u} f) differentiable at x" if "a < x" "x < b" "x \<noteq> i" "x \<notin> I" for x
  proof -
    from that consider "x < i" |"i < x" by arith
    then show ?thesis
    proof cases
      case 1
      have at: "at x within {a<..<i} - I = at x"
        using that 1
        by (intro at_within_open) (auto intro!: open_Diff finite_imp_closed \<open>finite I\<close>)
      then have "(\<lambda>u. integral {a..u} f1) differentiable at x within {a<..<i} - I"
        using that 1 f1 by auto
      then have "(\<lambda>u. integral {a..u} f) differentiable at x within {a<..<i} - I"
        apply (rule differentiable_transform_within[OF _ zero_less_one])
        using that combine.hyps 1 by (auto intro!: integral_cong)
      then show ?thesis by (simp add: at)
    next
      case 2
      have at: "at x within {i<..<b} - I = at x"
        using that 2
        by (intro at_within_open) (auto intro!: open_Diff finite_imp_closed \<open>finite I\<close>)
      then have "(\<lambda>u. integral {a..i} f + integral {i..u} f2) differentiable at x within {i<..<b} - I"
        using that 2 f2 by auto
      then have "(\<lambda>u. integral {a..i} f + integral {i..u} f) differentiable at x within {i<..<b} - I"
        apply (rule differentiable_transform_within[OF _ zero_less_one])
        using that combine.hyps 2 by (auto intro!: integral_spike[where S="{i,x}"])
      then have "(\<lambda>u. integral {a..u} f) differentiable at x within {i<..<b} - I"
        apply (rule differentiable_transform_within[OF _ zero_less_one])
        subgoal using that 2 by auto
        apply (auto simp: )
        apply (subst Henstock_Kurzweil_Integration.integral_combine)
        using that 2 \<open>a \<le> i\<close>
        apply auto
        by (auto intro: integrable_on_subinterval f_int)
      then show ?thesis by (simp add: at)
    qed
  qed
  moreover
  have "(\<lambda>t. integral {a..t} f) differentiable at_right x" if "a \<le> x" "x < b" for x
  proof -
    from that consider "x < i" |"i \<le> x" by arith
    then show ?thesis
    proof cases
      case 1
      have at: "at x within {x..i} = at_right x"
        using \<open>x < i\<close> by (rule at_within_Icc_at_right)
      then have "(\<lambda>u. integral {a..u} f1) differentiable at x within {x..i}"
        using that 1 f1 by auto
      then have "(\<lambda>u. integral {a..u} f) differentiable at x within {x..i}"
        apply (rule differentiable_transform_within[OF _ zero_less_one])
        using that combine.hyps 1 by (auto intro!: integral_spike[where S="{i,x}"])
      then show ?thesis by (simp add: at)
    next
      case 2
      have at: "at x within {x..b} = at_right x"
        using \<open>x < b\<close> by (rule at_within_Icc_at_right)
      then have "(\<lambda>u. integral {a..i} f + integral {i..u} f2) differentiable at x within {x..b}"
        using that 2 f2 by auto
      then have "(\<lambda>u. integral {a..i} f + integral {i..u} f) differentiable at x within {x..b}"
        apply (rule differentiable_transform_within[OF _ zero_less_one])
        using that combine.hyps 2 by (auto intro!: integral_spike[where S="{i,x}"])
      then have "(\<lambda>u. integral {a..u} f) differentiable at x within {x..b}"
        apply (rule differentiable_transform_within[OF _ zero_less_one])
        subgoal using that 2 by auto
        apply (auto simp: )
        apply (subst Henstock_Kurzweil_Integration.integral_combine)
        using that 2 \<open>a \<le> i\<close>
        apply auto
        by (auto intro: integrable_on_subinterval f_int)
      then show ?thesis by (simp add: at)
    qed
  qed
  moreover
  have "(\<lambda>t. integral {a..t} f) differentiable at_left x" if "a < x" "x \<le> b" for x
  proof -
    from that consider "x \<le> i" |"i < x" by arith
    then show ?thesis
    proof cases
      case 1
      have at: "at x within {a..x} = at_left x"
        using \<open>a < x\<close> by (rule at_within_Icc_at_left)
      then have "(\<lambda>u. integral {a..u} f1) differentiable at x within {a..x}"
        using that 1 f1 by auto
      then have "(\<lambda>u. integral {a..u} f) differentiable at x within {a..x}"
        apply (rule differentiable_transform_within[OF _ zero_less_one])
        using that combine.hyps 1 by (auto intro!: integral_spike[where S="{i,x}"])
      then show ?thesis by (simp add: at)
    next
      case 2
      have at: "at x within {i..x} = at_left x"
        using \<open>i < x\<close> by (rule at_within_Icc_at_left)
      then have "(\<lambda>u. integral {a..i} f + integral {i..u} f2) differentiable at x within {i..x}"
        using that 2 f2 by auto
      then have "(\<lambda>u. integral {a..i} f + integral {i..u} f) differentiable at x within {i..x}"
        apply (rule differentiable_transform_within[OF _ zero_less_one])
        using that combine.hyps 2 by (auto intro!: integral_spike[where S="{i,x}"])
      then have "(\<lambda>u. integral {a..u} f) differentiable at x within {i..x}"
        apply (rule differentiable_transform_within[OF _ zero_less_one])
        subgoal using that 2 by auto
        apply (auto simp: )
        apply (subst Henstock_Kurzweil_Integration.integral_combine)
        using that 2 \<open>a \<le> i\<close>
        apply auto
        by (auto intro: integrable_on_subinterval f_int)
      then show ?thesis by (simp add: at)
    qed
  qed
  ultimately
  show ?case
    by auto
next
  case (weaken a b i I f)
  from weaken.IH[OF \<open>a < b\<close>]
  obtain l u where IH:
    "\<And>x. a < x \<Longrightarrow> x < b \<Longrightarrow> x \<notin> I \<Longrightarrow> (\<lambda>u. integral {a..u} f) differentiable (at x)"
    "\<And>x. a \<le> x \<Longrightarrow> x < b \<Longrightarrow> (\<lambda>t. integral {a..t} f) differentiable (at_right x)"
    "\<And>x. a < x \<Longrightarrow> x \<le> b \<Longrightarrow> (\<lambda>t. integral {a..t} f) differentiable (at_left x)"
    by metis
  then show ?case by auto
qed

lemma "closure (-S) \<inter> closure S = frontier S"
  by (auto simp add: frontier_def closure_complement)

theorem integral_time_domain_has_laplace:
  "((\<lambda>t. integral {0 .. t} f) has_laplace L / s) s"
  if pc: "\<And>k. piecewise_continuous_on 0 k D f"
    and eo: "exponential_order M c f"
    and L: "(f has_laplace L) s"
    and s: "Re s > c"
    and c: "c > 0"
    and TODO: "D = {}" \<comment> \<open>TODO: generalize to actual \<open>piecewise_continuous_on\<close>\<close>
  for f::"real \<Rightarrow> complex"
proof -
  define I where "I = (\<lambda>t. integral {0 .. t} f)"
  have I': "(I has_vector_derivative f t) (at t within {0..x} - D)"
    if "t \<in> {0 .. x} - D"
    for x t
    unfolding I_def
    by (rule integral_has_vector_derivative_piecewise_continuous; fact)
  have fi: "f integrable_on {0..t}" for t
    by (rule piecewise_continuous_on_integrable) fact
  have Ic: "continuous_on {0 .. t} I" for t
    unfolding I_def using fi
    by (rule indefinite_integral_continuous_1)
  have Ipc: "piecewise_continuous_on 0 t {} I" for t
    by (rule piecewise_continuous_onI) (auto intro!: Ic)
  have I: "(f has_integral I t) {0 .. t}" for t
    unfolding I_def
    using fi
    by (rule integrable_integral)
  from exponential_order_integral[OF I eo \<open>0 < c\<close>] obtain M'
    where Ieo: "exponential_order M' c I" .
  have Ili: "laplace_integrand I s integrable_on {0..}"
    using Ipc
    apply (rule piecewise_continuous_on_AE_boundedE)
    apply (rule laplace_integrand_integrable)
    apply (rule Ieo)
      apply assumption
     apply (rule integrable_continuous_interval)
     apply (rule Ic)
    apply (rule s)
    done
  then obtain LI where LI: "(I has_laplace LI) s"
    by (rule laplace_exists_laplace_integrandI)

  from piecewise_continuous_onE[OF pc] have \<open>finite D\<close> by auto
  have I'2: "(I has_vector_derivative f t) (at t)" if "t > 0" "t \<notin> D" for t
    apply (subst at_within_open[symmetric, where S="{0<..<t+1} - D"])
    subgoal using that by auto
    subgoal by (auto intro!:open_Diff finite_imp_closed \<open>finite D\<close>)
    subgoal using I'[where x="t + 1"]
      apply (rule has_vector_derivative_within_subset)
      using that
      by auto
    done
  have I_tndsto: "(I \<longlongrightarrow> 0) (at_right 0)"
    apply (rule tendsto_eq_rhs)
     apply (rule continuous_on_Icc_at_rightD)
      apply (rule Ic)
    apply (rule zero_less_one)
    by (auto simp: I_def)
  have "(f has_laplace s * LI - 0) s"
    by (rule has_laplace_derivative_time_domain[OF LI I'2 I_tndsto Ieo s])
      (auto simp: TODO)
  from has_laplace_unique[OF this L] have "LI = L / s"
    using s c by auto
  with LI show "(I has_laplace L / s) s" by simp
qed

subsection \<open>higher derivatives\<close>

definition "nderiv i f X = ((\<lambda>f. (\<lambda>x. vector_derivative f (at x within X)))^^i) f"

definition "ndiff n f X \<longleftrightarrow> (\<forall>i<n. \<forall>x \<in> X. nderiv i f X differentiable at x within X)"

lemma nderiv_Suc[simp]:
  "nderiv (Suc i) f X x = vector_derivative (nderiv i f X) (at x within X)"
  by (auto simp: nderiv_def)

lemma ndiff_zero[simp]: "ndiff 0 f X"
  by (auto simp: ndiff_def)

lemma ndiff_Sucs[simp]:
  "ndiff (Suc i) f X \<longleftrightarrow>
    (ndiff i f X) \<and>
    (\<forall>x \<in> X. (nderiv i f X) differentiable (at x within X))"
  apply (auto simp: ndiff_def )
  using less_antisym by blast

theorem has_laplace_vector_derivative:
  "((\<lambda>t. vector_derivative f (at t)) has_laplace s * L - f0) s"
  if L: "(f has_laplace L) s"
    and f': "\<And>t. t > 0 \<Longrightarrow> f differentiable (at t)"
    and f0: "(f \<longlongrightarrow> f0) (at_right 0)"
    and eo: "exponential_order M c f"
    and cs: "c < Re s"
proof -
  have f': "(\<And>t. 0 < t \<Longrightarrow> (f has_vector_derivative vector_derivative f (at t)) (at t))"
    using f'
    by (subst vector_derivative_works[symmetric])
  show ?thesis
    by (rule has_laplace_derivative_time_domain[OF L f' f0 eo cs])
qed

lemma has_laplace_nderiv:
  "(nderiv n f {0<..} has_laplace s^n * L - (\<Sum>i<n. s^(n - Suc i) * f0 i)) s"
  if L: "(f has_laplace L) s"
    and f': "ndiff n f {0<..}"
    and f0: "\<And>i. i < n \<Longrightarrow> (nderiv i f {0<..} \<longlongrightarrow> f0 i) (at_right 0)"
    and eo: "\<And>i. i < n \<Longrightarrow> exponential_order M c (nderiv i f {0<..})"
    and cs: "c < Re s"
  using f' f0 eo
proof (induction n)
  case 0
  then show ?case
    by (auto simp: L)
next
  case (Suc n)
  have awo: "at t within {0<..} = at t" if "t > 0" for t::real
    using that
    by (subst at_within_open) auto
  have "((\<lambda>a. vector_derivative (nderiv n f {0<..}) (at a)) has_laplace
    s * ( s ^ n * L - (\<Sum>i<n. s^(n - Suc i) * f0 i)) - f0 n) s"
    (is "(_ has_laplace ?L) _")
    apply (rule has_laplace_vector_derivative)
        apply (rule Suc.IH)
    subgoal using Suc.prems by auto
    subgoal using Suc.prems by auto
    subgoal using Suc.prems by auto
    subgoal using Suc.prems by (auto simp: awo)
    subgoal using Suc.prems by auto
     apply (rule Suc.prems; force)
    apply (rule cs)
    done
  also have "?L = s ^ Suc n * L - (\<Sum>i<Suc n. s ^ (Suc n - Suc i) * f0 i)"
    by (auto simp: algebra_simps sum_distrib_left diff_Suc Suc_diff_le
        split: nat.splits
        intro!: sum.cong)
  finally show ?case
    by (rule has_laplace_spike[where T="{0}"]) (auto simp: awo)
qed

end


section \<open>Roots of Real and Complex Algebraic Polynomials\<close>

text \<open>We are now able to actually compute all roots of polynomials
  with real and complex algebraic coefficients. The main addition to
  calculating the representative polynomial for a superset of all roots
  is to find the genuine roots. For this we utilize the approximation algorithm
  via interval arithmetic.\<close>

theory Roots_of_Real_Complex_Poly
  imports
    Roots_of_Algebraic_Poly_Impl
    Roots_via_IA
    MPoly_Container
begin

hide_const (open) Module.smult

typedef (overloaded) 'a rf_poly = "{ p :: 'a :: idom poly. rsquarefree p}"
  by (intro exI[of _ 1], auto simp: rsquarefree_def)

setup_lifting type_definition_rf_poly

context
begin
lifting_forget poly.lifting

lift_definition poly_rf :: "'a :: idom rf_poly \<Rightarrow> 'a poly" is "\<lambda> x. x" .

definition roots_of_poly_dummy :: "'a::{comm_ring_1,ring_no_zero_divisors} poly \<Rightarrow> _"
  where "roots_of_poly_dummy p = (SOME xs. set xs = {r. poly p r = 0} \<and> distinct xs)"

lemma roots_of_poly_dummy_code[code]:
  "roots_of_poly_dummy p = Code.abort (STR ''roots-of-poly-dummy'') (\<lambda> x. roots_of_poly_dummy p)"
  by simp

lemma roots_of_poly_dummy: assumes p: "p \<noteq> 0"
  shows "set (roots_of_poly_dummy p) = {x. poly p x = 0}" "distinct (roots_of_poly_dummy p)"
proof -
  from someI_ex[OF finite_distinct_list[OF poly_roots_finite[OF p]], folded roots_of_poly_dummy_def]
  show "set (roots_of_poly_dummy p) = {x. poly p x = 0}" "distinct (roots_of_poly_dummy p)"  by auto
qed

lift_definition roots_of_complex_rf_poly_part1 :: "complex rf_poly \<Rightarrow> complex genuine_roots_aux" is
  "\<lambda> p. if Ball (set (Polynomial.coeffs p)) algebraic then
        let q = representative_poly p;
         zeros = complex_roots_of_int_poly q
         in (p,zeros,Polynomial.degree p, filter_fun_complex p)
        else (p,roots_of_poly_dummy p,Polynomial.degree p, filter_fun_complex p)"
  subgoal for p
  proof -
    assume rp: "rsquarefree p"
    hence card: "card {x. poly p x = 0} = Polynomial.degree p"
      using rsquarefree_card_degree rsquarefree_def by blast
    from rp have p: "p \<noteq> 0" unfolding rsquarefree_def by auto
    have ff: "filter_fun p (filter_fun_complex p)" by (rule filter_fun_complex)
    show ?thesis
    proof (cases "Ball (set (Polynomial.coeffs p)) algebraic")
      case False
      with roots_of_poly_dummy[OF p] ff
      show ?thesis using rp card by auto
    next
      case True
      from rp card representative_poly_complex[of p]
        complex_roots_of_int_poly[of "representative_poly p"] ff
      show ?thesis unfolding Let_def rsquarefree_def using True by auto
    qed
  qed
  done

lift_definition roots_of_real_rf_poly_part1 :: "real rf_poly \<Rightarrow> real genuine_roots_aux" is
  "\<lambda> p. let n = count_roots p in
        if Ball (set (Polynomial.coeffs p)) algebraic then
        let q = representative_poly p;
         zeros = real_roots_of_int_poly q
         in (p,zeros,n, filter_fun_real p)
        else (p,roots_of_poly_dummy p,n, filter_fun_real p)"
  subgoal for p
  proof -
    assume rp: "rsquarefree p"
    from rp have p: "p \<noteq> 0" unfolding rsquarefree_def by auto
    have ff: "filter_fun p (filter_fun_real p)" by (rule filter_fun_real)
    show ?thesis
    proof (cases "Ball (set (Polynomial.coeffs p)) algebraic")
      case False
      with roots_of_poly_dummy[OF p] ff
      show ?thesis using rp by (auto simp: Let_def count_roots_correct)
    next
      case True
      from rp representative_poly_real[of p]
        real_roots_of_int_poly[of "representative_poly p"] ff
      show ?thesis unfolding Let_def rsquarefree_def using True
        by (auto simp: count_roots_correct)
    qed
  qed
  done

definition roots_of_complex_rf_poly :: "complex rf_poly \<Rightarrow> complex list" where
  "roots_of_complex_rf_poly p = genuine_roots_impl (roots_of_complex_rf_poly_part1 p)"

lemma roots_of_complex_rf_poly: "set (roots_of_complex_rf_poly p) = {x. poly (poly_rf p) x = 0}"
  "distinct (roots_of_complex_rf_poly p)"
  unfolding roots_of_complex_rf_poly_def genuine_roots_impl
  by (transfer, auto simp: genuine_roots_impl)

definition roots_of_real_rf_poly :: "real rf_poly \<Rightarrow> real list" where
  "roots_of_real_rf_poly p = genuine_roots_impl (roots_of_real_rf_poly_part1 p)"

lemma roots_of_real_rf_poly: "set (roots_of_real_rf_poly p) = {x. poly (poly_rf p) x = 0}"
  "distinct (roots_of_real_rf_poly p)"
  unfolding roots_of_real_rf_poly_def genuine_roots_impl
  by (transfer, auto simp: genuine_roots_impl Let_def)

typedef (overloaded) 'a rf_polys = "{ (a :: 'a :: idom, ps :: ('a poly \<times> nat) list). Ball (fst ` set ps) rsquarefree}"
  by (intro exI[of _ "(_,Nil)"], auto)

setup_lifting type_definition_rf_polys

lift_definition yun_polys :: "'a :: {euclidean_ring_gcd,field_char_0,semiring_gcd_mult_normalize} poly \<Rightarrow> 'a rf_polys"
  is "\<lambda> p. yun_factorization gcd p"
  subgoal for p
    apply auto
    apply (intro square_free_rsquarefree)
    apply (insert yun_factorization[of p, OF refl])
    by (cases "yun_factorization gcd p", auto dest: square_free_factorizationD)
  done

context
  notes [[typedef_overloaded]]
begin
lift_definition (code_dt) yun_rf :: "'a :: idom rf_polys \<Rightarrow> 'a \<times> ('a rf_poly \<times> nat) list" is "\<lambda> x. x"
  by (auto simp: list_all_iff, force)
end
end
definition polys_rf :: "'a :: idom rf_polys \<Rightarrow> 'a rf_poly list" where
  "polys_rf = map fst o snd o yun_rf"

lemma yun_polys: assumes "p \<noteq> 0"
  shows "poly p x = 0 \<longleftrightarrow> (\<exists> q \<in> set (polys_rf (yun_polys p)). poly (poly_rf q) x = 0)"
  using assms unfolding polys_rf_def o_def
  apply transfer
  subgoal for p x
  proof -
    assume p: "p \<noteq> 0"
    obtain c ps where yun: "yun_factorization gcd p = (c,ps)" by force
    from yun_factorization[OF this] have sff: "square_free_factorization p (c, ps)" by auto
    from square_free_factorizationD'(1)[OF sff] p have c0: "c \<noteq> 0" by auto
    show ?thesis unfolding yun
      unfolding square_free_factorizationD'(1)[OF sff] poly_smult poly_prod_list snd_conv
      mult_eq_0_iff prod_list_zero_iff
      using c0 by force
  qed
  done

definition roots_of_complex_rf_polys :: "complex rf_polys \<Rightarrow> complex list" where
  "roots_of_complex_rf_polys ps = concat (map roots_of_complex_rf_poly (polys_rf ps))"

lemma roots_of_complex_rf_polys:
  "set (roots_of_complex_rf_polys ps) = {x. \<exists> p \<in> set (polys_rf ps). poly (poly_rf p) x = 0 }"
  unfolding roots_of_complex_rf_polys_def set_concat set_map image_comp o_def
    roots_of_complex_rf_poly by auto

definition roots_of_real_rf_polys :: "real rf_polys \<Rightarrow> real list" where
  "roots_of_real_rf_polys ps = concat (map roots_of_real_rf_poly (polys_rf ps))"

lemma roots_of_real_rf_polys:
  "set (roots_of_real_rf_polys ps) = {x. \<exists> p \<in> set (polys_rf ps). poly (poly_rf p) x = 0 }"
  unfolding roots_of_real_rf_polys_def set_concat set_map image_comp o_def
    roots_of_real_rf_poly by auto

definition roots_of_complex_poly :: "complex poly \<Rightarrow> complex list" where
  "roots_of_complex_poly p = (if p = 0 then [] else roots_of_complex_rf_polys (yun_polys p))"

lemma roots_of_complex_poly: assumes p: "p \<noteq> 0"
  shows "set (roots_of_complex_poly p) = {x. poly p x = 0}"
  using p unfolding roots_of_complex_poly_def
  by (simp add: roots_of_complex_rf_polys yun_polys[OF p])

definition roots_of_real_poly :: "real poly \<Rightarrow> real list" where
  "roots_of_real_poly p = (if p = 0 then [] else roots_of_real_rf_polys (yun_polys p))"

lemma roots_of_real_poly: assumes p: "p \<noteq> 0"
  shows "set (roots_of_real_poly p) = {x. poly p x = 0}"
  using p unfolding roots_of_real_poly_def
  by (simp add: roots_of_real_rf_polys yun_polys[OF p])

lemma distinct_concat':
  "\<lbrakk> distinct (list_neq xs []);
     \<And> ys. ys \<in> set xs \<Longrightarrow> distinct ys;
     \<And> ys zs. \<lbrakk> ys \<in> set xs ; zs \<in> set xs ; ys \<noteq> zs \<rbrakk> \<Longrightarrow> set ys \<inter> set zs = {}
   \<rbrakk> \<Longrightarrow> distinct (concat xs)"
  by (induct xs, auto split: if_splits)

lemma roots_of_rf_yun_polys_distinct: assumes
  rt: "\<And> p. set (rop p) = {x. poly (poly_rf p) x = 0}"
  and dist: "\<And> p. distinct (rop p)"
shows "distinct (concat (map rop (polys_rf (yun_polys p))))"
  using assms unfolding polys_rf_def
proof (transfer, goal_cases)
  case (1 rop p)
  obtain c fs where yun: "yun_factorization gcd p = (c,fs)" by force
  note sff = yun_factorization(1)[OF yun]
  note sff1 = square_free_factorizationD[OF sff]
  note sff2 = square_free_factorizationD'[OF sff]
  have rs: "(p,i) \<in> set fs \<Longrightarrow> rsquarefree p" for p i
    by (intro square_free_rsquarefree, insert sff1(2), auto)
  note 1 = 1[OF rs]
  show ?case unfolding yun snd_conv map_map o_def using 1 sff1(3,5)
  proof (induct fs)
    case (Cons pi fs)
    obtain p i where pi: "pi = (p,i)" by force
    hence "(p,i) \<in> set (pi # fs)" by auto
    note p_i = Cons(2-4)[OF this]
    have IH: "distinct (concat (map (\<lambda>x. rop (fst x)) fs))"
      by (rule Cons(1)[OF Cons(2,3,4)], insert Cons(5), auto)
    {
      fix x
      assume x: "x \<in> set (rop p)" "x \<in> (\<Union>x\<in>set fs. set (rop (fst x)))"
      from x[unfolded p_i] have rtp: "poly p x = 0" by auto
      from x obtain q j where qj: "(q,j) \<in> set fs" and x: "x \<in> set (rop q)" by force
      from Cons(2)[of q j] x qj have rtq: "poly q x = 0" by auto
      from Cons(5)[unfolded pi] qj have "(p,i) \<noteq> (q,j)" by auto
      from p_i(3)[OF _ this] qj have cop: "algebraic_semidom_class.coprime p q" by auto
      from rtp have dvdp: "[:-x,1:] dvd p" using poly_eq_0_iff_dvd by blast
      from rtq have dvdq: "[:-x,1:] dvd q" using poly_eq_0_iff_dvd by blast
      from cop dvdp dvdq have "is_unit [:-x,1:]" by (metis coprime_common_divisor)
      hence False by simp
    }
    thus ?case unfolding pi by (auto simp: p_i(2) IH)
  qed simp
qed

lemma distinct_roots_of_real_poly: "distinct (roots_of_real_poly p)"
  unfolding roots_of_real_poly_def roots_of_real_rf_polys_def
  using roots_of_rf_yun_polys_distinct[of roots_of_real_rf_poly p, OF roots_of_real_rf_poly]
  by auto

lemma distinct_roots_of_complex_poly: "distinct (roots_of_complex_poly p)"
  unfolding roots_of_complex_poly_def roots_of_complex_rf_polys_def
  using roots_of_rf_yun_polys_distinct[of roots_of_complex_rf_poly p, OF roots_of_complex_rf_poly]
  by auto

end


section {* A PDL Textbook Exercise *}

context fmodal_kleene_algebra
begin

definition T :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("_\<leadsto>_\<leadsto>_" [61,61,61] 60)
  where "p\<leadsto>x\<leadsto>q = a(p)+\<bar>x]d(q)"

lemma T_d: "d(p\<leadsto>x\<leadsto>q) = p\<leadsto>x\<leadsto>q"
  by (metis a_closure fbox_simp_2 d5 T_def)

lemma T_p: "d(p)\<cdot>(p\<leadsto>x\<leadsto>q) = d(p)\<cdot>\<bar>x]d(q)"
  by (metis T_def distl a_comp_1 add_zerol)

lemma T_a: "a(p)\<cdot>(p\<leadsto>x\<leadsto>q) = a(p)"
  by (metis T_def a_closure domain_absorption_1 fbox_simp_2)

lemma T_seq: "(p\<leadsto>x\<leadsto>q)\<cdot>\<bar>x](q\<leadsto>y\<leadsto>s) \<le> p\<leadsto>x\<cdot>y\<leadsto>s"
proof -
  have "(p\<leadsto>x\<leadsto>q)\<cdot>\<bar>x](q\<leadsto>y\<leadsto>s) \<le> a(p)+\<bar>x](d(q)\<cdot>(q\<leadsto>y\<leadsto>s))"
    by (smt distr fbox_simp_2 dom_subid mult_oner add_iso mult_isol fbox_add1 domain_invol T_def T_d)
  thus ?thesis
    by (smt T_p dom_subid mult_onel fbox_iso mult_isor add_iso fbox_simp add_comm fbox_simp_2 dom_mult_closed fbox_mult T_def order_trans)
qed

lemma T_square: "(p\<leadsto>x\<leadsto>q)\<cdot>\<bar>x](q\<leadsto>x\<leadsto>p) \<le> p\<leadsto>x\<cdot>x\<leadsto>p"
  by (metis T_seq)

lemma T_segerberg: "\<bar>x\<^sup>\<star>]d(p) = d(p)\<cdot>\<bar>x\<^sup>\<star>](p\<leadsto>x\<leadsto>p)"
  by (metis fbox_segerberg T_def add_comm)

lemma lookahead: "\<bar>x\<^sup>\<star>](d(p)\<cdot>\<bar>x]d(p)) = \<bar>x\<^sup>\<star>]d(p)"
  by (metis fbox_add1 fbox_simp_2 fbox_mult domain_invol fbox_add2 add_lub add_ub eq_iff star_1l star_slide_var)

lemma alternation: "\<bar>(x\<cdot>x)\<^sup>\<star>](d(p)\<cdot>(q\<leadsto>x\<leadsto>p))\<cdot>\<bar>x\<cdot>(x\<cdot>x)\<^sup>\<star>](d(q)\<cdot>(p\<leadsto>x\<leadsto>q)) = d(p)\<cdot>\<bar>x\<^sup>\<star>]((p\<leadsto>x\<leadsto>q)\<cdot>(q\<leadsto>x\<leadsto>p))"
proof -
  have "d(p)\<cdot>\<bar>x\<^sup>\<star>]((p\<leadsto>x\<leadsto>q)\<cdot>(q\<leadsto>x\<leadsto>p)) = d(p)\<cdot>(\<bar>(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q)\<cdot>(q\<leadsto>x\<leadsto>p))\<cdot>\<bar>(x\<cdot>x)\<^sup>\<star>]\<bar>x]((p\<leadsto>x\<leadsto>q)\<cdot>(q\<leadsto>x\<leadsto>p)))"
    by (smt meyer_1 mult_onel distr fbox_add2 fbox_simp star_slide fbox_mult)
  also have "\<dots> = d(p)\<cdot>\<bar>(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q)\<cdot>\<bar>x](q\<leadsto>x\<leadsto>p)\<cdot>(q\<leadsto>x\<leadsto>p)\<cdot>\<bar>x](p\<leadsto>x\<leadsto>q))"
    by (smt T_d dom_el_comm dom_mult_closed fbox_add1 fbox_simp_2 mult_assoc)
  also have "\<dots> = d(p)\<cdot>\<bar>(x\<cdot>x)\<^sup>\<star>](p\<leadsto>x\<cdot>x\<leadsto>p)\<cdot>\<bar>(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q)\<cdot>\<bar>x](q\<leadsto>x\<leadsto>p)\<cdot>(q\<leadsto>x\<leadsto>p)\<cdot>\<bar>x](p\<leadsto>x\<leadsto>q))"
    by (smt domain_order T_seq fbox_simp_2 dom_mult_closed mult_assoc dom_el_comm T_d fbox_add1)
  also have "\<dots> = \<bar>(x\<cdot>x)\<^sup>\<star>]d(p)\<cdot>\<bar>(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q)\<cdot>\<bar>x](q\<leadsto>x\<leadsto>p)\<cdot>(q\<leadsto>x\<leadsto>p)\<cdot>\<bar>x](p\<leadsto>x\<leadsto>q))"
    by (metis T_segerberg)
  also have "\<dots> = \<bar>(x\<cdot>x)\<^sup>\<star>](d(p)\<cdot>(q\<leadsto>x\<leadsto>p)\<cdot>(\<bar>x]d(q)\<cdot>\<bar>x](q\<leadsto>x\<leadsto>p)\<cdot>\<bar>x](p\<leadsto>x\<leadsto>q)))"
    by (smt fbox_add1 mult_assoc domain_invol fbox_simp_2 dom_mult_closed T_d T_p dom_el_comm)
  also have "\<dots> = \<bar>(x\<cdot>x)\<^sup>\<star>](d(p)\<cdot>\<bar>x\<cdot>x]d(p))\<cdot>\<bar>(x\<cdot>x)\<^sup>\<star>]((q\<leadsto>x\<leadsto>p)\<cdot>\<bar>x](d(q)\<cdot>(p\<leadsto>x\<leadsto>q)))"
    by (smt fbox_add1 fbox_simp_2 a_closure d5 domain_invol dom_mult_closed T_d T_p dom_el_comm mult_assoc fbox_mult)
  finally show ?thesis
    by (smt lookahead fbox_add1 fbox_simp_2 domain_invol dom_mult_closed mult_assoc fbox_mult star_slide T_d)
qed

lemma meyer: "\<bar>(x\<cdot>x)\<^sup>\<star>]d(p)\<cdot>\<bar>x\<cdot>(x\<cdot>x)\<^sup>\<star>]a(p) = d(p)\<cdot>\<bar>x\<^sup>\<star>]((p\<leadsto>x\<leadsto>a(p))\<cdot>(a(p)\<leadsto>x\<leadsto>p))"
  by (metis alternation antidomain_semiring_domain_def T_a a_closure)

lemma segerberg_again: "\<bar>x\<^sup>\<star>]d(p) = d(p)\<cdot>\<bar>x\<^sup>\<star>](p\<leadsto>x\<leadsto>p)"
  by (smt T_d dom_el_idemp alternation fbox_add2 meyer_1 mult_onel distr T_p lookahead)


theory seminarski
  imports Main Complex_Main

begin

(*
https://www.imo-official.org/problems/IMO2008SL.pdf

Zadatak A2:
(a) Prove the inequality
    x^2 / (x-1)^2 + y^2 / (y-1)^2 + z^2 / (z-1)^2 \<ge> 1
for real numbers x, y, z \<noteq> 1 satisfying the condition x * y * z = 1.

(b) Show that there are infinitely many triples of rational numbers
x, y, z for which this inequality turns into equality.
*)

(* Izraz koji se nalazi sa leve strane nejednakosti *)
fun izraz :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real" where
  "izraz x y z = (x^2)/(x-1)^2 + (y^2)/(y-1)^2 + (z^2)/(z-1)^2"

(* Uvodim promenljive a, b, c*)
fun a :: "real \<Rightarrow> real" where
"a x = x / (x - 1)"

fun b :: "real \<Rightarrow> real" where
"b y = y / (y - 1)"

fun c :: "real \<Rightarrow> real" where
"c z = z / (z - 1)"

(*
  Zapisujem levu stranu nejednakosti preko promenljivih
  a, b, c koje sam uvela i dokazujem jednakost ta dva.
*)
lemma dokaz_jednakosti:
  assumes "\<forall> x y z :: real. x \<noteq> 1 \<and> y \<noteq> 1 \<and> z \<noteq> 1 \<and> x * y * z = 1"
      shows "izraz x y z = (a x)^2 + (b y)^2 + (c z)^2"
  using assms
  by blast

lemma zadatak_a:
  assumes "\<forall> x y z :: real. x \<noteq> 1 \<and> y \<noteq> 1 \<and> z \<noteq> 1 \<and> x * y * z = 1"
  shows "(a x)^2 + (b y)^2 + (c z)^2 \<ge> 1"
  using assms
  (*by blast *)
proof-
  have "(a x - 1) * (b y - 1) * (c z - 1) = a x * b x * c y"
    using assms
    by blast
  then have "(a x * b y - a x - b y + 1) * (c z - 1) = a x * b y * c z"
    using assms
    by blast
  then have "a x * b y * c z - a x * b y - a x * c z + a x - b y * c z + b y + c z - 1 = a x * b y * c z"
    using assms
    by blast
  then have "a x + b y + c z - 1 = a x * b y + b y * c z + c z * a x"
    using assms
    by blast
  then have "a x + b y + c z - 1 = ((a x + b y + c z)^2 - ((a x)^2 + (b y)^2 + (c z)^2)) / 2"
    using assms
    by blast
  then have "2 * (a x + b y + c z - 1) = (a x + b y + c z)^2 - ((a x)^2 + (b y)^2 + (c z)^2)"
    using assms
    by blast
  then have "(a x)^2 + (b y)^2 + (c z)^2 - 2 = (a x + b y + c z)^2 - 2*(a x + b y + c z)"
    using assms
    by blast
  then have "(a x)^2 + (b y)^2 + (c z)^2 - 1 = (a x + b y + c z - 1)^2"
    using assms
    by blast
  then have "((a x)^2 + (b y)^2 + (c z)^2) = 1 + (a x + b y + c z - 1) ^ 2"
    using assms
    by blast
  then have "((a x)^2 + (b y)^2 + (c z)^2) \<ge> 1"
    by auto
  then show ?thesis
  using assms
  by auto
qed

(*
  (b) Show that there are infinitely many triples of rational numbers
  x, y, z for which this inequality turns into equality.
*)
lemma zadatak_b:
  assumes "\<forall> x y z :: real. x \<noteq> 1 \<and> y \<noteq> 1 \<and> z \<noteq> 1 \<and> x * y * z = 1"
  shows "(a x)^2 + (b y)^2 + (c z)^2 = 1  "
  using assms
  by auto

end