(*  Title:      HOL/Library/Saturated.thy
    Author:     Brian Huffman
    Author:     Peter Gammie
    Author:     Florian Haftmann
*)

section \<open>Saturated arithmetic\<close>

theory Saturated
imports Numeral_Type Type_Length
begin

subsection \<open>The type of saturated naturals\<close>

typedef (overloaded) ('a::len) sat = "{.. LENGTH('a)}"
  morphisms nat_of Abs_sat
  by auto

lemma sat_eqI:
  "nat_of m = nat_of n \<Longrightarrow> m = n"
  by (simp add: nat_of_inject)

lemma sat_eq_iff:
  "m = n \<longleftrightarrow> nat_of m = nat_of n"
  by (simp add: nat_of_inject)

lemma Abs_sat_nat_of [code abstype]:
  "Abs_sat (nat_of n) = n"
  by (fact nat_of_inverse)

definition Abs_sat' :: "nat \<Rightarrow> 'a::len sat" where
  "Abs_sat' n = Abs_sat (min (LENGTH('a)) n)"

lemma nat_of_Abs_sat' [simp]:
  "nat_of (Abs_sat' n :: ('a::len) sat) = min (LENGTH('a)) n"
  unfolding Abs_sat'_def by (rule Abs_sat_inverse) simp

lemma nat_of_le_len_of [simp]:
  "nat_of (n :: ('a::len) sat) \<le> LENGTH('a)"
  using nat_of [where x = n] by simp

lemma min_len_of_nat_of [simp]:
  "min (LENGTH('a)) (nat_of (n::('a::len) sat)) = nat_of n"
  by (rule min.absorb2 [OF nat_of_le_len_of])

lemma min_nat_of_len_of [simp]:
  "min (nat_of (n::('a::len) sat)) (LENGTH('a)) = nat_of n"
  by (subst min.commute) simp

lemma Abs_sat'_nat_of [simp]:
  "Abs_sat' (nat_of n) = n"
  by (simp add: Abs_sat'_def nat_of_inverse)

instantiation sat :: (len) linorder
begin

definition
  less_eq_sat_def: "x \<le> y \<longleftrightarrow> nat_of x \<le> nat_of y"

definition
  less_sat_def: "x < y \<longleftrightarrow> nat_of x < nat_of y"

instance
  by standard
    (auto simp add: less_eq_sat_def less_sat_def not_le sat_eq_iff min.coboundedI1 mult.commute)

end

instantiation sat :: (len) "{minus, comm_semiring_1}"
begin

definition
  "0 = Abs_sat' 0"

definition
  "1 = Abs_sat' 1"

lemma nat_of_zero_sat [simp, code abstract]:
  "nat_of 0 = 0"
  by (simp add: zero_sat_def)

lemma nat_of_one_sat [simp, code abstract]:
  "nat_of 1 = min 1 (LENGTH('a))"
  by (simp add: one_sat_def)

definition
  "x + y = Abs_sat' (nat_of x + nat_of y)"

lemma nat_of_plus_sat [simp, code abstract]:
  "nat_of (x + y) = min (nat_of x + nat_of y) (LENGTH('a))"
  by (simp add: plus_sat_def)

definition
  "x - y = Abs_sat' (nat_of x - nat_of y)"

lemma nat_of_minus_sat [simp, code abstract]:
  "nat_of (x - y) = nat_of x - nat_of y"
proof -
  from nat_of_le_len_of [of x] have "nat_of x - nat_of y \<le> LENGTH('a)" by arith
  then show ?thesis by (simp add: minus_sat_def)
qed

definition
  "x * y = Abs_sat' (nat_of x * nat_of y)"

lemma nat_of_times_sat [simp, code abstract]:
  "nat_of (x * y) = min (nat_of x * nat_of y) (LENGTH('a))"
  by (simp add: times_sat_def)

instance
proof
  fix a b c :: "'a::len sat"
  show "a * b * c = a * (b * c)"
  proof(cases "a = 0")
    case True thus ?thesis by (simp add: sat_eq_iff)
  next
    case False show ?thesis
    proof(cases "c = 0")
      case True thus ?thesis by (simp add: sat_eq_iff)
    next
      case False with \<open>a \<noteq> 0\<close> show ?thesis
        by (simp add: sat_eq_iff nat_mult_min_left nat_mult_min_right mult.assoc min.assoc min.absorb2)
    qed
  qed
  show "1 * a = a"
    by (simp add: sat_eq_iff min_def not_le not_less)
  show "(a + b) * c = a * c + b * c"
  proof(cases "c = 0")
    case True thus ?thesis by (simp add: sat_eq_iff)
  next
    case False thus ?thesis
      by (simp add: sat_eq_iff nat_mult_min_left add_mult_distrib min_add_distrib_left min_add_distrib_right min.assoc min.absorb2)
  qed
qed (simp_all add: sat_eq_iff mult.commute)

end

instantiation sat :: (len) ordered_comm_semiring
begin

instance
  by standard
    (auto simp add: less_eq_sat_def less_sat_def not_le sat_eq_iff min.coboundedI1 mult.commute)

end

lemma Abs_sat'_eq_of_nat: "Abs_sat' n = of_nat n"
  by (rule sat_eqI, induct n, simp_all)

abbreviation Sat :: "nat \<Rightarrow> 'a::len sat" where
  "Sat \<equiv> of_nat"

lemma nat_of_Sat [simp]:
  "nat_of (Sat n :: ('a::len) sat) = min (LENGTH('a)) n"
  by (rule nat_of_Abs_sat' [unfolded Abs_sat'_eq_of_nat])

lemma [code_abbrev]:
  "of_nat (numeral k) = (numeral k :: 'a::len sat)"
  by simp

context
begin

qualified definition sat_of_nat :: "nat \<Rightarrow> ('a::len) sat"
  where [code_abbrev]: "sat_of_nat = of_nat"

lemma [code abstract]:
  "nat_of (sat_of_nat n :: ('a::len) sat) = min (LENGTH('a)) n"
  by (simp add: sat_of_nat_def)

end

instance sat :: (len) finite
proof
  show "finite (UNIV::'a sat set)"
    unfolding type_definition.univ [OF type_definition_sat]
    using finite by simp
qed

instantiation sat :: (len) equal
begin

definition "HOL.equal A B \<longleftrightarrow> nat_of A = nat_of B"

instance
  by standard (simp add: equal_sat_def nat_of_inject)

end

instantiation sat :: (len) "{bounded_lattice, distrib_lattice}"
begin

definition "(inf :: 'a sat \<Rightarrow> 'a sat \<Rightarrow> 'a sat) = min"
definition "(sup :: 'a sat \<Rightarrow> 'a sat \<Rightarrow> 'a sat) = max"
definition "bot = (0 :: 'a sat)"
definition "top = Sat (LENGTH('a))"

instance
  by standard
    (simp_all add: inf_sat_def sup_sat_def bot_sat_def top_sat_def max_min_distrib2,
      simp_all add: less_eq_sat_def)

end

instantiation sat :: (len) "{Inf, Sup}"
begin

global_interpretation Inf_sat: semilattice_neutr_set min \<open>top :: 'a sat\<close>
  defines Inf_sat = Inf_sat.F
  by standard (simp add: min_def)

global_interpretation Sup_sat: semilattice_neutr_set max \<open>bot :: 'a sat\<close>
  defines Sup_sat = Sup_sat.F
  by standard (simp add: max_def bot.extremum_unique)

instance ..

end

instance sat :: (len) complete_lattice
proof
  fix x :: "'a sat"
  fix A :: "'a sat set"
  note finite
  moreover assume "x \<in> A"
  ultimately show "Inf A \<le> x"
    by (induct A) (auto intro: min.coboundedI2)
next
  fix z :: "'a sat"
  fix A :: "'a sat set"
  note finite
  moreover assume z: "\<And>x. x \<in> A \<Longrightarrow> z \<le> x"
  ultimately show "z \<le> Inf A" by (induct A) simp_all
next
  fix x :: "'a sat"
  fix A :: "'a sat set"
  note finite
  moreover assume "x \<in> A"
  ultimately show "x \<le> Sup A"
    by (induct A) (auto intro: max.coboundedI2)
next
  fix z :: "'a sat"
  fix A :: "'a sat set"
  note finite
  moreover assume z: "\<And>x. x \<in> A \<Longrightarrow> x \<le> z"
  ultimately show "Sup A \<le> z" by (induct A) auto
next
  show "Inf {} = (top::'a sat)"
    by (auto simp: top_sat_def)
  show "Sup {} = (bot::'a sat)"
    by (auto simp: bot_sat_def)
qed

end


section "Splay Heap"

theory Splay_Heap_Analysis
imports
  Splay_Tree.Splay_Heap
  Amortized_Framework
  Priority_Queue_ops
  Lemmas_log
begin

text \<open>Timing functions must be kept in sync with the corresponding functions
on splay heaps.\<close>

fun T_part :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> nat" where
"T_part p Leaf = 1" |
"T_part p (Node l a r) =
  (if a \<le> p then
     case r of
       Leaf \<Rightarrow> 1 |
       Node rl b rr \<Rightarrow> if b \<le> p then T_part p rr + 1 else T_part p rl + 1
   else case l of
       Leaf \<Rightarrow> 1 |
       Node ll b lr \<Rightarrow> if b \<le> p then T_part p lr + 1 else T_part p ll + 1)"

definition T_in :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> nat" where
"T_in x h = T_part x h"

fun T_dm :: "'a::linorder tree \<Rightarrow> nat" where
"T_dm Leaf = 1" |
"T_dm (Node Leaf _ r) = 1" |
"T_dm (Node (Node ll a lr) b r) = (if ll=Leaf then 1 else T_dm ll + 1)"

abbreviation "\<phi> t == log 2 (size1 t)"

fun \<Phi> :: "'a tree \<Rightarrow> real" where
"\<Phi> Leaf = 0" |
"\<Phi> (Node l a r) = \<Phi> l + \<Phi> r + \<phi> (Node l a r)"

lemma amor_del_min: "T_dm t + \<Phi> (del_min t) - \<Phi> t \<le> 2 * \<phi> t + 1"
proof(induction t rule: T_dm.induct)
  case (3 ll a lr b r)
  let ?t = "Node (Node ll a lr) b r"
  show ?case
  proof cases
    assume [simp]: "ll = Leaf"
    have 1: "log 2 (real (size1 lr) + real (size1 r))
        \<le> 3 * log 2 (1 + (real (size1 lr) + real (size1 r)))" (is "?l \<le> 3 * ?r")
    proof -
      have "?l \<le> ?r" by(simp add: size1_size)
      also have "\<dots> \<le> 3 * ?r" by(simp)
      finally show ?thesis .
    qed
    have 2: "log 2 (1 + real (size1 lr)) \<ge> 0" by simp
    thus ?case apply simp using 1 2 by linarith
  next
    assume ll[simp]: "\<not> ll = Leaf"
    let ?l' = "del_min ll"
    let ?s = "Node ll a lr"  let ?t = "Node ?s b r"
    let ?s' = "Node lr b r"  let ?t' = "Node ?l' a ?s'"
    have 0: "\<phi> ?t' \<le> \<phi> ?t" by(simp add: size1_size)
    have 1: "\<phi> ll < \<phi> ?s" by(simp add: size1_size)
    have 2: "log 2 (size1 ll + size1 ?s') \<le> log 2 (size1 ?t)" by(simp add: size1_size)
    have "T_dm ?t + \<Phi> (del_min ?t) - \<Phi> ?t
        = 1 + T_dm ll + \<Phi> (del_min ?t) - \<Phi> ?t" by simp
    also have "\<dots> \<le> 2 + 2 * \<phi> ll + \<Phi> ll - \<Phi> ?l'  + \<Phi> (del_min ?t) - \<Phi> ?t"
      using 3 ll by linarith
    also have "\<dots> = 2 + 2 * \<phi> ll + \<phi> ?t' + \<phi> ?s' - \<phi> ?t - \<phi> ?s" by(simp)
    also have "\<dots> \<le> 2 + \<phi> ll + \<phi> ?s'" using 0 1 by linarith
    also have "\<dots> < 2 * \<phi> ?t + 1" using 2 ld_ld_1_less[of "size1 ll" "size1 ?s'"]
      by (simp add: size1_size)
    finally show ?case by simp
  qed
qed auto

lemma zig_zig:
fixes s u r r1' r2' T a b
defines "t == Node s a (Node u b r)" and "t' == Node (Node s a u) b r1'"
assumes "size r1' \<le> size r"
    "T_part p r + \<Phi> r1' + \<Phi> r2' - \<Phi> r \<le> 2 * \<phi> r + 1"
shows "T_part p r + 1 + \<Phi> t' + \<Phi> r2' - \<Phi> t \<le> 2 * \<phi> t + 1"
proof -
  have 1: "\<phi> r \<le> \<phi> (Node u b r)" by (simp add: size1_size)
  have 2: "log 2 (real (size1 s + size1 u + size1 r1')) \<le> \<phi> t"
    using assms(3) by (simp add: t_def size1_size)
  from ld_ld_1_less[of "size1 s + size1 u" "size1 r"]
  have "1 + \<phi> r + log 2 (size1 s + size1 u) \<le> 2 * log 2 (size1 s + size1 u + size1 r)"
    by(simp add: size1_size)
  thus ?thesis using assms 1 2 by (simp add: algebra_simps)
qed

lemma zig_zag:
fixes s u r r1' r2' a b
defines "t \<equiv> Node s a (Node r b u)" and "t1' == Node s a r1'" and "t2' \<equiv> Node u b r2'"
assumes "size r = size r1' + size r2'"
    "T_part p r + \<Phi> r1' + \<Phi> r2' - \<Phi> r \<le> 2 * \<phi> r + 1"
shows "T_part p r + 1 + \<Phi> t1' + \<Phi> t2' - \<Phi> t \<le> 2 * \<phi> t + 1"
proof -
  have 1: "\<phi> r \<le> \<phi> (Node u b r)" by (simp add: size1_size)
  have 2: "\<phi> r \<le> \<phi> t" by (simp add: t_def size1_size)
  from ld_ld_less2[of "size1 s + size1 r1'" "size1 u + size1 r2'"]
  have "1 + log 2 (size1 s + size1 r1') + log 2 (size1 u + size1 r2') \<le> 2 * \<phi> t"
    by(simp add: assms(4) size1_size t_def ac_simps)
  thus ?thesis using assms 1 2 by (simp add: algebra_simps)
qed

lemma amor_partition: "bst_wrt (\<le>) t \<Longrightarrow> partition p t = (l',r')
  \<Longrightarrow> T_part p t + \<Phi> l' + \<Phi> r' - \<Phi> t \<le> 2 * log 2 (size1 t) + 1"
proof(induction p t arbitrary: l' r' rule: partition.induct)
  case 1 thus ?case by simp
next
  case (2 p l a r)
  show ?case
  proof cases
    assume "a \<le> p"
    show ?thesis
    proof (cases r)
      case Leaf thus ?thesis using \<open>a \<le> p\<close> "2.prems" by fastforce
    next
      case [simp]: (Node rl b rr)
      let ?t = "Node l a r"
      show ?thesis
      proof cases
        assume "b \<le> p"
        with \<open>a \<le> p\<close> "2.prems" obtain rrl
          where 0: "partition p rr = (rrl, r')" "l' = Node (Node l a rl) b rrl"
          by (auto split: tree.splits prod.splits)
        have "size rrl \<le> size rr"
          using size_partition[OF 0(1)] by (simp add: size1_size)
        with 0 \<open>a \<le> p\<close> \<open>b \<le> p\<close> "2.prems"(1) "2.IH"(1)[OF _ Node , of rrl r']
          zig_zig[where s=l and u=rl and r=rr and r1'=rrl and r2'=r' and p=p, of a b]
        show ?thesis by (simp add: algebra_simps)
      next
        assume "\<not> b \<le> p"
        with \<open>a \<le> p\<close> "2.prems" obtain rll rlr
          where 0: "partition p rl = (rll, rlr)" "l' = Node l a rll" "r' = Node rlr b rr"
          by (auto split: tree.splits prod.splits)
        from 0 \<open>a \<le> p\<close> \<open>\<not> b \<le> p\<close> "2.prems"(1) "2.IH"(2)[OF _ Node, of rll rlr]
          size_partition[OF 0(1)]
          zig_zag[where s=l and u=rr and r=rl and r1'=rll and r2'=rlr and p=p, of a b]
        show ?thesis by (simp add: algebra_simps)
      qed
    qed
  next
    assume "\<not> a \<le> p"
    show ?thesis
    proof (cases l)
      case Leaf thus ?thesis using \<open>\<not> a \<le> p\<close> "2.prems" by fastforce
    next
      case [simp]: (Node ll b lr)
      let ?t = "Node l a r"
      show ?thesis
      proof cases
        assume "b \<le> p"
        with \<open>\<not> a \<le> p\<close> "2.prems" obtain lrl lrr
          where 0: "partition p lr = (lrl, lrr)" "l' = Node ll b lrl" "r' = Node lrr a r"
          by (auto split: tree.splits prod.splits)
        from 0 \<open>\<not> a \<le> p\<close> \<open>b \<le> p\<close> "2.prems"(1) "2.IH"(3)[OF _ Node, of lrl lrr]
          size_partition[OF 0(1)]
          zig_zag[where s=r and u=ll and r=lr and r1'=lrr and r2'=lrl and p=p, of a b]
        show ?thesis by (auto simp: algebra_simps)
      next
        assume "\<not> b \<le> p"
        with \<open>\<not> a \<le> p\<close> "2.prems" obtain llr
          where 0: "partition p ll = (l',llr)" "r' = Node llr b (Node lr a r)"
          by (auto split: tree.splits prod.splits)
        have "size llr \<le> size ll"
          using size_partition[OF 0(1)] by (simp add: size1_size)
        with 0 \<open>\<not> a \<le> p\<close> \<open>\<not> b \<le> p\<close> "2.prems"(1) "2.IH"(4)[OF _ Node, of l' llr]
          zig_zig[where s=r and u=lr and r=ll and r1'=llr and r2'=l' and p=p, of a b]
        show ?thesis by (auto simp: algebra_simps)
      qed
    qed
  qed
qed

fun exec :: "'a::linorder op \<Rightarrow> 'a tree list \<Rightarrow> 'a tree" where
"exec Empty [] = Leaf" |
"exec (Insert a) [t] = insert a t" |
"exec Del_min [t] = del_min t"

fun cost :: "'a::linorder op \<Rightarrow> 'a tree list \<Rightarrow> nat" where
"cost Empty [] = 1" |
"cost (Insert a) [t] = T_in a t" |
"cost Del_min [t] = T_dm t"

fun U where
"U Empty [] = 1" |
"U (Insert _) [t] = 3 * log 2 (size1 t + 1) + 1" |
"U Del_min [t] = 2 * \<phi> t + 1"

interpretation Amortized
where arity = arity and exec = exec and inv = "bst_wrt (\<le>)"
and cost = cost and \<Phi> = \<Phi> and U = U
proof (standard, goal_cases)
  case (1 _ f) thus ?case
    by(cases f)
       (auto simp: insert_def bst_del_min dest!: bst_partition split: prod.splits)
next
  case (2 h) thus ?case by(induction h) (auto simp: size1_size)
next
  case (3 s f)
  show ?case
  proof (cases f)
    case Empty with 3 show ?thesis by(auto)
  next
    case Del_min with 3 show ?thesis by(auto simp: amor_del_min)
  next
    case [simp]: (Insert x)
    then obtain t where [simp]: "s = [t]" "bst_wrt (\<le>) t" using 3 by auto
    { fix l r assume 1: "partition x t = (l,r)"
      have "log 2 (1 + size t) < log 2 (2 + size t)" by simp
      with 1 amor_partition[OF \<open>bst_wrt (\<le>) t\<close> 1] size_partition[OF 1] have ?thesis
        by(simp add: T_in_def insert_def algebra_simps size1_size
             del: log_less_cancel_iff) }
    thus ?thesis by(simp add: insert_def split: prod.split)
  qed
qed

end


chapter \<open>Exp Upper and Lower Bounds\<close>

theory Exp_Bounds
imports Bounds_Lemmas
        "HOL-Library.Sum_of_Squares"
        Sturm_Sequences.Sturm

begin

text\<open>Covers all bounds used in exp-upper.ax, exp-lower.ax and exp-extended.ax.\<close>

section \<open>Taylor Series Bounds\<close>

text\<open>\<open>exp_positive\<close> is the theorem @{thm Transcendental.exp_ge_zero}\<close>

text\<open>\<open>exp_lower_taylor_1\<close> is the theorem @{thm Transcendental.exp_ge_add_one_self}\<close>

text\<open>All even approximants are lower bounds.\<close>
lemma exp_lower_taylor_even:
  fixes x::real
  shows "even n \<Longrightarrow> (\<Sum>m<n. (x ^ m) / (fact m)) \<le> exp x"
  using Maclaurin_exp_le [of x n]
  by (auto simp add: zero_le_even_power)

lemma exp_upper_taylor_even:
  fixes x::real
  assumes n: "even n"
      and pos: "(\<Sum>m<n. ((-x) ^ m) / (fact m)) > 0"  (is "?sum > 0")
    shows "exp x \<le> inverse ?sum"
  using exp_lower_taylor_even [OF n, of "-x"]
  by (metis exp_minus inverse_inverse_eq le_imp_inverse_le pos)

text\<open>3 if the previous lemma is expressed in terms of @{term "2*m"}.\<close>
lemma exp_lower_taylor_3:
  fixes x::real
  shows "1 + x + (1/2)*x^2 + (1/6)*x^3 + (1/24)*x^4 + (1/120)*x^5 \<le> exp x"
  by (rule order_trans [OF _ exp_lower_taylor_even [of 6]])
     (auto simp: lessThan_nat_numeral fact_numeral)

lemma exp_lower_taylor_2:
  fixes x::real
  shows "1 + x + (1/2)*x^2 + (1/6)*x^3 \<le> exp x"
proof -
  have "even (4::nat)" by simp
  then have "(\<Sum>m<4. x ^ m / (fact m)) \<le> exp x"
    by (rule exp_lower_taylor_even)
  then show ?thesis by (auto simp add: numeral_eq_Suc)
qed

lemma exp_upper_bound_case_3:
  fixes x::real
  assumes "x \<le> 3.19"
  shows "exp x \<le> 2304 / (-(x^3) + 6*x^2 - 24*x + 48)^2"
proof -
  have "(1/48)*(-(x^3) + 6*x^2 - 24*x + 48) = (1 + (-x/2) + (1/2)*(-x/2)^2 + (1/6)*(-x/2)^3)"
    by (simp add: field_simps power2_eq_square power3_eq_cube)
  also have "... \<le> exp (-x/2)"
    by (rule exp_lower_taylor_2)
  finally have 1: "(1/48)*(-(x^3) + 6*x^2 - 24*x + 48) \<le> exp (-x/2)" .
  have "(-(x^3) + 6*x^2 - 24*x + 48)^2 / 2304 = ((1/48)*(-(x^3) + 6*x^2 - 24*x + 48))^2"
    by (simp add: field_simps power2_eq_square power3_eq_cube)
  also have "... \<le> (exp (-x/2))^2"
    apply (rule power_mono [OF 1])
    apply (simp add: algebra_simps)
    using assms
    apply (sos "((R<1 + ((R<1 * ((R<1323/13 * [~15/49*x + 1]^2) + (R<1/637 * [x]^2))) + (((A<0 * R<1) * (R<50/13 * [1]^2)) + ((A<=0 * R<1) * ((R<56/13 * [~5/56*x + 1]^2) + (R<199/728 * [x]^2)))))))")
    done
  also have "... = inverse (exp x)"
    by (metis exp_minus mult_exp_exp power2_eq_square field_sum_of_halves)
  finally have 2: "(-(x^3) + 6*x^2 - 24*x + 48)^2 / 2304 \<le> inverse (exp x)" .
  have "6 * x\<^sup>2 - x ^ 3 - 24 * x + 48 \<noteq> 0" using assms
    by (sos "((R<1 + (([~400/13] * A=0) + ((R<1 * ((R<1323/13 * [~15/49*x + 1]^2) + (R<1/637 * [x]^2))) + ((A<=0 * R<1) * ((R<56/13 * [~5/56*x + 1]^2) + (R<199/728 * [x]^2)))))))")
  then show ?thesis
    using Fields.linordered_field_class.le_imp_inverse_le [OF 2]
    by simp
qed

lemma exp_upper_bound_case_5:
  fixes x::real
  assumes "x \<le> 6.36"
  shows "exp x \<le> 21743271936 / (-(x^3) + 12*x^2 - 96*x + 384)^4"
proof -
  have "(1/384)*(-(x^3) + 12*x^2 - 96*x + 384) = (1 + (-x/4) + (1/2)*(-x/4)^2 + (1/6)*(-x/4)^3)"
    by (simp add: field_simps power2_eq_square power3_eq_cube)
  also have "... \<le> exp (-x/4)"
    by (rule exp_lower_taylor_2)
  finally have 1: "(1/384)*(-(x^3) + 12*x^2 - 96*x + 384) \<le> exp (-x/4)" .
  have "(-(x^3) + 12*x^2 - 96*x + 384)^4 / 21743271936 = ((1/384)*(-(x^3) + 12*x^2 - 96*x + 384))^4"
    by (simp add: divide_simps)
  also have "... \<le> (exp (-x/4))^4"
    apply (rule power_mono [OF 1])
    apply (simp add: algebra_simps)
    using assms
    apply (sos "((R<1 + ((R<1 * ((R<1777/32 * [~539/3554*x + 1]^2) + (R<907/227456 * [x]^2))) + (((A<0 * R<1) * (R<25/1024 * [1]^2)) + ((A<=0 * R<1) * ((R<49/32 * [~2/49*x + 1]^2) + (R<45/1568 * [x]^2)))))))")
    done
  also have "... = inverse (exp x)"
    by (simp add: exp_of_nat_mult [symmetric] exp_minus [symmetric])
  finally have 2: "(-(x^3) + 12*x^2 - 96*x + 384)^4 / 21743271936 \<le> inverse (exp x)" .
  have "12 * x\<^sup>2 - x ^ 3 - 96 * x + 384 \<noteq> 0" using assms
    by (sos "((R<1 + (([~25/32] * A=0) + ((R<1 * ((R<1777/32 * [~539/3554*x + 1]^2) + (R<907/227456 * [x]^2))) + ((A<=0 * R<1) * ((R<49/32 * [~2/49*x + 1]^2) + (R<45/1568 * [x]^2)))))))")
  then show ?thesis
    using Fields.linordered_field_class.le_imp_inverse_le [OF 2]
    by simp
qed

section \<open>Continued Fraction Bound 2\<close>

definition exp_cf2 :: "real \<Rightarrow> real"
  where "exp_cf2 \<equiv> \<lambda>x. (x^2 + 6*x + 12) / (x^2 - 6*x + 12)"

lemma denom_cf2_pos: fixes x::real shows "x\<^sup>2 - 6 * x + 12 > 0"
  by (sos "((R<1 + ((R<1 * ((R<5 * [~3/10*x + 1]^2) + (R<1/20 * [x]^2))) + ((A<=0 * R<1) * (R<1/2 * [1]^2)))))")

lemma numer_cf2_pos: fixes x::real shows "x\<^sup>2 + 6 * x + 12 > 0"
  by (sos "((R<1 + ((R<1 * ((R<5 * [3/10*x + 1]^2) + (R<1/20 * [x]^2))) + ((A<=0 * R<1) * (R<1/2 * [1]^2)))))")

lemma exp_cf2_pos: "exp_cf2 x > 0"
  unfolding exp_cf2_def
  by (auto simp add: divide_simps denom_cf2_pos numer_cf2_pos)

definition diff_delta_lnexp_cf2 :: "real \<Rightarrow> real"
  where "diff_delta_lnexp_cf2 \<equiv> \<lambda>x. - (x^4) / ((x^2 - 6*x + 12) * (x^2 + 6*x + 12))"

lemma d_delta_lnexp_cf2_nonpos: "diff_delta_lnexp_cf2 x \<le> 0"
unfolding diff_delta_lnexp_cf2_def
by (sos "(((R<1 + ((R<1 * ((R<5/4 * [~3/40*x^2 + 1]^2) + (R<11/1280 * [x^2]^2))) +
      ((A<1 * R<1) * (R<1/64 * [1]^2))))) & ((R<1 + ((R<1 * ((R<5/4 * [~3/40*x^2 + 1]^2) + (R<11/1280 * [x^2]^2))) + ((A<1 * R<1) * (R<1/64 * [1]^2))))))")

lemma d_delta_lnexp_cf2:
    "((\<lambda>x. ln (exp_cf2 x) - x) has_field_derivative diff_delta_lnexp_cf2 x) (at x)"
  unfolding exp_cf2_def diff_delta_lnexp_cf2_def
  apply (intro derivative_eq_intros | simp)+
  apply (metis exp_cf2_def exp_cf2_pos)
  apply (simp_all add: )
  using denom_cf2_pos [of x] numer_cf2_pos [of x]
  apply (auto simp: divide_simps)
  apply algebra
  done

text\<open>Upper bound for non-positive x\<close>
lemma ln_exp_cf2_upper_bound_neg:
  assumes "x \<le> 0"
    shows "x \<le> ln (exp_cf2 x)"
  by (rule gen_upper_bound_decreasing [OF assms d_delta_lnexp_cf2 d_delta_lnexp_cf2_nonpos])
     (simp add: exp_cf2_def)

theorem exp_cf2_upper_bound_neg: "x\<le>0 \<Longrightarrow> exp(x) \<le> exp_cf2 x"
  by (metis ln_exp_cf2_upper_bound_neg exp_cf2_pos exp_le_cancel_iff exp_ln_iff)

text\<open>Lower bound for non-negative x\<close>
lemma ln_exp_cf2_lower_bound_pos:
  assumes "0\<le>x"
    shows "ln (exp_cf2 x) \<le> x"
  by (rule gen_lower_bound_increasing [OF assms d_delta_lnexp_cf2 d_delta_lnexp_cf2_nonpos])
     (simp add: exp_cf2_def)

theorem exp_cf2_lower_bound_pos: "0\<le>x \<Longrightarrow> exp_cf2 x \<le> exp x"
  by (metis exp_cf2_pos exp_le_cancel_iff exp_ln ln_exp_cf2_lower_bound_pos)

section \<open>Continued Fraction Bound 3\<close>

text\<open>This bound crosses the X-axis twice, causing complications.\<close>

definition numer_cf3 :: "real \<Rightarrow> real"
  where "numer_cf3 \<equiv> \<lambda>x. x^3 + 12*x^2 + 60*x + 120"

definition exp_cf3 :: "real \<Rightarrow> real"
  where "exp_cf3 \<equiv> \<lambda>x. numer_cf3 x / numer_cf3 (-x)"

lemma numer_cf3_pos: "-4.64 \<le> x \<Longrightarrow> numer_cf3 x > 0"
  unfolding numer_cf3_def
  by sturm

lemma exp_cf3_pos: "numer_cf3 x > 0 \<Longrightarrow> numer_cf3 (-x) > 0 \<Longrightarrow> exp_cf3 x > 0"
  by (simp add: exp_cf3_def)

definition diff_delta_lnexp_cf3 :: "real \<Rightarrow> real"
  where "diff_delta_lnexp_cf3 \<equiv> \<lambda>x. (x^6) / (numer_cf3 (-x) * numer_cf3 x)"

lemma d_delta_lnexp_cf3_nonneg: "numer_cf3 x > 0 \<Longrightarrow> numer_cf3 (-x) > 0 \<Longrightarrow> diff_delta_lnexp_cf3 x \<ge> 0"
  unfolding diff_delta_lnexp_cf3_def
  by (auto simp: mult_less_0_iff intro: divide_nonneg_neg)

lemma d_delta_lnexp_cf3:
  assumes "numer_cf3 x > 0" "numer_cf3 (-x) > 0"
  shows "((\<lambda>x. ln (exp_cf3 x) - x) has_field_derivative diff_delta_lnexp_cf3 x) (at x)"
unfolding exp_cf3_def numer_cf3_def diff_delta_lnexp_cf3_def
apply (intro derivative_eq_intros | simp)+
using assms numer_cf3_pos [of x] numer_cf3_pos [of "-x"]
apply (auto simp: numer_cf3_def)
apply (auto simp add: divide_simps add_nonneg_eq_0_iff)
apply algebra
done

lemma numer_cf3_mono: "y \<le> x \<Longrightarrow> numer_cf3 y \<le> numer_cf3 x"
  unfolding numer_cf3_def
  by (sos "(((A<0 * R<1) + ((A<=0 * R<1) * ((R<60 * [1/10*x + 1/10*y + 1]^2) +
                ((R<2/5 * [x + ~1/4*y]^2) + (R<3/8 * [y]^2))))))")

text\<open>Upper bound for non-negative x\<close>
lemma ln_exp_cf3_upper_bound_nonneg:
  assumes x0: "0 \<le> x" and xless: "numer_cf3 (-x) > 0"
    shows "x \<le> ln (exp_cf3 x)"
proof -
  have ncf3: "\<And>y. 0 \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> numer_cf3 (-y) > 0"
    by (metis neg_le_iff_le numer_cf3_mono order.strict_trans2 xless)
  show ?thesis
    apply (rule gen_upper_bound_increasing [OF x0 d_delta_lnexp_cf3 d_delta_lnexp_cf3_nonneg])
    apply (auto simp add: ncf3 assms numer_cf3_pos)
    apply (simp add: exp_cf3_def numer_cf3_def)
    done
qed

theorem exp_cf3_upper_bound_pos: "0 \<le> x \<Longrightarrow> numer_cf3 (-x) > 0 \<Longrightarrow> exp x \<le> exp_cf3 x"
  using ln_exp_cf3_upper_bound_nonneg [of x] exp_cf3_pos [of x] numer_cf3_pos [of x]
  by auto (metis exp_le_cancel_iff exp_ln_iff)

corollary "0 \<le> x \<Longrightarrow> x \<le> 4.64 \<Longrightarrow> exp x \<le> exp_cf3 x"
  by (metis numer_cf3_pos neg_le_iff_le exp_cf3_upper_bound_pos)

text\<open>Lower bound for negative x, provided @{term"exp_cf3 x > 0"}]\<close>
lemma ln_exp_cf3_lower_bound_neg:
  assumes x0: "x \<le> 0" and xgtr: "numer_cf3 x > 0"
    shows "ln (exp_cf3 x) \<le> x"
proof -
  have ncf3: "\<And>y. x \<le> y \<Longrightarrow> y \<le> 0 \<Longrightarrow> numer_cf3 y > 0"
    by (metis dual_order.strict_trans1 numer_cf3_mono xgtr)
  show ?thesis
    apply (rule gen_lower_bound_decreasing [OF x0 d_delta_lnexp_cf3 d_delta_lnexp_cf3_nonneg])
    apply (auto simp add: ncf3 assms numer_cf3_pos)
    apply (simp add: exp_cf3_def numer_cf3_def)
    done
qed

theorem exp_cf3_lower_bound_pos:
  assumes "x \<le> 0" shows "exp_cf3 x \<le> exp x"
proof (cases "numer_cf3 x > 0")
  case True
  then have "exp_cf3 x > 0"
    using assms numer_cf3_pos [of "-x"]
    by (auto simp: exp_cf3_pos)
  then show ?thesis
  using ln_exp_cf3_lower_bound_neg [of x] assms True
    by auto (metis exp_le_cancel_iff exp_ln_iff)
next
  case False
  then have "exp_cf3 x \<le> 0"
    using assms numer_cf3_pos [of "-x"]
    unfolding exp_cf3_def
    by (simp add: divide_nonpos_pos)
  then show ?thesis
    by (metis exp_ge_zero order.trans)
qed

section \<open>Continued Fraction Bound 4\<close>

text \<open>Here we have the extended exp continued fraction bounds\<close>

definition numer_cf4 :: "real \<Rightarrow> real"
  where "numer_cf4 \<equiv> \<lambda>x. x^4 + 20*x^3 + 180*x^2 + 840*x + 1680"

definition exp_cf4 :: "real \<Rightarrow> real"
  where "exp_cf4 \<equiv> \<lambda>x. numer_cf4 x / numer_cf4 (-x)"

lemma numer_cf4_pos: fixes x::real shows "numer_cf4 x > 0"
unfolding numer_cf4_def
by (sos "((R<1 + ((R<1 * ((R<4469/256 * [1135/71504*x^2 + 4725/17876*x + 1]^2) + ((R<3728645/18305024 * [536265/2982916*x^2 + x]^2) + (R<106265/24436047872 * [x^2]^2)))) + ((A<=0 * R<1) * (R<45/4096 * [1]^2)))))")

lemma exp_cf4_pos: "exp_cf4 x > 0"
  unfolding exp_cf4_def
  by (auto simp add: divide_simps numer_cf4_pos)

definition diff_delta_lnexp_cf4 :: "real \<Rightarrow> real"
  where "diff_delta_lnexp_cf4 \<equiv> \<lambda>x. - (x^8) / (numer_cf4 (-x) * numer_cf4 x)"

lemma d_delta_lnexp_cf4_nonpos: "diff_delta_lnexp_cf4 x \<le> 0"
  unfolding diff_delta_lnexp_cf4_def
  using numer_cf4_pos [of x] numer_cf4_pos [of "-x"]
  by (simp add: zero_le_divide_iff zero_le_mult_iff)

lemma d_delta_lnexp_cf4:
    "((\<lambda>x. ln (exp_cf4 x) - x) has_field_derivative diff_delta_lnexp_cf4 x) (at x)"
  unfolding exp_cf4_def numer_cf4_def diff_delta_lnexp_cf4_def
  apply (intro derivative_eq_intros | simp)+
  using exp_cf4_pos
  apply (simp add: exp_cf4_def numer_cf4_def)
  apply (simp_all add: )
  using numer_cf4_pos [of x]  numer_cf4_pos [of "-x"]
  apply (auto simp: divide_simps numer_cf4_def)
  apply algebra
  done

text\<open>Upper bound for non-positive x\<close>
lemma ln_exp_cf4_upper_bound_neg:
  assumes "x \<le> 0"
    shows "x \<le> ln (exp_cf4 x)"
  by (rule gen_upper_bound_decreasing [OF assms d_delta_lnexp_cf4 d_delta_lnexp_cf4_nonpos])
     (simp add: exp_cf4_def numer_cf4_def)

theorem exp_cf4_upper_bound_neg: "x\<le>0 \<Longrightarrow> exp(x) \<le> exp_cf4 x"
  by (metis ln_exp_cf4_upper_bound_neg exp_cf4_pos exp_le_cancel_iff exp_ln_iff)

text\<open>Lower bound for non-negative x\<close>
lemma ln_exp_cf4_lower_bound_pos:
  assumes "0\<le>x"
    shows "ln (exp_cf4 x) \<le> x"
  by (rule gen_lower_bound_increasing [OF assms d_delta_lnexp_cf4 d_delta_lnexp_cf4_nonpos])
     (simp add: exp_cf4_def numer_cf4_def)

theorem exp_cf4_lower_bound_pos: "0\<le>x \<Longrightarrow> exp_cf4 x \<le> exp x"
  by (metis exp_cf4_pos exp_le_cancel_iff exp_ln ln_exp_cf4_lower_bound_pos)

section \<open>Continued Fraction Bound 5\<close>

text\<open>This bound crosses the X-axis twice, causing complications.\<close>

definition numer_cf5 :: "real \<Rightarrow> real"
  where "numer_cf5 \<equiv> \<lambda>x. x^5 + 30*x^4 + 420*x^3 + 3360*x^2 + 15120*x + 30240"

definition exp_cf5 :: "real \<Rightarrow> real"
  where "exp_cf5 \<equiv> \<lambda>x. numer_cf5 x / numer_cf5 (-x)"

lemma numer_cf5_pos: "-7.293 \<le> x \<Longrightarrow> numer_cf5 x > 0"
  unfolding numer_cf5_def
  by sturm

lemma exp_cf5_pos: "numer_cf5 x > 0 \<Longrightarrow> numer_cf5 (-x) > 0 \<Longrightarrow> exp_cf5 x > 0"
  unfolding exp_cf5_def numer_cf5_def
  by (simp add: divide_neg_neg)

definition diff_delta_lnexp_cf5 :: "real \<Rightarrow> real"
  where "diff_delta_lnexp_cf5 \<equiv> \<lambda>x. (x^10) / (numer_cf5 (-x) * numer_cf5 x)"

lemma d_delta_lnexp_cf5_nonneg: "numer_cf5 x > 0 \<Longrightarrow> numer_cf5 (-x) > 0 \<Longrightarrow> diff_delta_lnexp_cf5 x \<ge> 0"
  unfolding diff_delta_lnexp_cf5_def
  by (auto simp add: mult_less_0_iff intro: divide_nonneg_neg )

lemma d_delta_lnexp_cf5:
  assumes "numer_cf5 x > 0" "numer_cf5 (-x) > 0"
  shows "((\<lambda>x. ln (exp_cf5 x) - x) has_field_derivative diff_delta_lnexp_cf5 x) (at x)"
unfolding exp_cf5_def numer_cf5_def diff_delta_lnexp_cf5_def
apply (intro derivative_eq_intros | simp)+
using assms numer_cf5_pos [of x] numer_cf5_pos [of "-x"]
apply (auto simp: numer_cf5_def)
apply (auto simp add: divide_simps add_nonneg_eq_0_iff)
apply algebra
done

subsection\<open>Proving monotonicity via a non-negative derivative\<close>

definition numer_cf5_deriv :: "real \<Rightarrow> real"
  where "numer_cf5_deriv \<equiv> \<lambda>x. 5*x^4 + 120*x^3 + 1260*x^2 + 6720*x + 15120"

lemma numer_cf5_deriv:
  shows "(numer_cf5 has_field_derivative numer_cf5_deriv x) (at x)"
  unfolding numer_cf5_def numer_cf5_deriv_def
  by (intro derivative_eq_intros | simp)+

lemma numer_cf5_deriv_pos: "numer_cf5_deriv x \<ge> 0"
  unfolding numer_cf5_deriv_def
  by (sos "((R<1 + ((R<1 * ((R<185533/8192 * [73459/5937056*x^2 + 43050/185533*x + 1]^2) + ((R<4641265253/24318181376 * [700850925/4641265253*x^2 + x]^2) + (R<38142496079/38933754831437824 * [x^2]^2)))) + ((A<0 * R<1) * (R<205/131072 * [1]^2)))))")

lemma numer_cf5_mono: "y \<le> x \<Longrightarrow> numer_cf5 y \<le> numer_cf5 x"
  by (auto intro: DERIV_nonneg_imp_nondecreasing numer_cf5_deriv numer_cf5_deriv_pos)

subsection\<open>Results\<close>

text\<open>Upper bound for non-negative x\<close>
lemma ln_exp_cf5_upper_bound_nonneg:
  assumes x0: "0 \<le> x" and xless: "numer_cf5 (-x) > 0"
    shows "x \<le> ln (exp_cf5 x)"
proof -
  have ncf5: "\<And>y. 0 \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> numer_cf5 (-y) > 0"
    by (metis neg_le_iff_le numer_cf5_mono order.strict_trans2 xless)
  show ?thesis
    apply (rule gen_upper_bound_increasing [OF x0 d_delta_lnexp_cf5 d_delta_lnexp_cf5_nonneg])
    apply (auto simp add: ncf5 assms numer_cf5_pos)
    apply (simp add: exp_cf5_def numer_cf5_def)
    done
qed

theorem exp_cf5_upper_bound_pos: "0 \<le> x \<Longrightarrow> numer_cf5 (-x) > 0 \<Longrightarrow> exp x \<le> exp_cf5 x"
  using ln_exp_cf5_upper_bound_nonneg [of x] exp_cf5_pos [of x] numer_cf5_pos [of x]
  by auto (metis exp_le_cancel_iff exp_ln_iff)

corollary "0 \<le> x \<Longrightarrow> x \<le> 7.293 \<Longrightarrow> exp x \<le> exp_cf5 x"
  by (metis neg_le_iff_le numer_cf5_pos exp_cf5_upper_bound_pos)

text\<open>Lower bound for negative x, provided @{term"exp_cf5 x > 0"}]\<close>
lemma ln_exp_cf5_lower_bound_neg:
  assumes x0: "x \<le> 0" and xgtr: "numer_cf5 x > 0"
    shows "ln (exp_cf5 x) \<le> x"
proof -
  have ncf5: "\<And>y. x \<le> y \<Longrightarrow> y \<le> 0 \<Longrightarrow> numer_cf5 y > 0"
    by (metis dual_order.strict_trans1 numer_cf5_mono xgtr)
  show ?thesis
    apply (rule gen_lower_bound_decreasing [OF x0 d_delta_lnexp_cf5 d_delta_lnexp_cf5_nonneg])
    apply (auto simp add: ncf5 assms numer_cf5_pos)
    apply (simp add: exp_cf5_def numer_cf5_def)
    done
qed

theorem exp_cf5_lower_bound_pos:
  assumes "x \<le> 0" shows "exp_cf5 x \<le> exp x"
proof (cases "numer_cf5 x > 0")
  case True
  then have "exp_cf5 x > 0"
    using assms numer_cf5_pos [of "-x"]
    by (auto simp: exp_cf5_pos)
  then show ?thesis
  using ln_exp_cf5_lower_bound_neg [of x] assms True
    by auto (metis exp_le_cancel_iff exp_ln_iff)
next
  case False
  then have "exp_cf5 x \<le> 0"
    using assms numer_cf5_pos [of "-x"]
    unfolding exp_cf5_def numer_cf5_def
    by (simp add: divide_nonpos_pos)
  then show ?thesis
    by (metis exp_ge_zero order.trans)
qed

section \<open>Continued Fraction Bound 6\<close>

definition numer_cf6 :: "real \<Rightarrow> real"
  where "numer_cf6 \<equiv> \<lambda>x. x^6 + 42*x^5 + 840*x^4 + 10080*x^3 + 75600*x^2 + 332640*x + 665280"

definition exp_cf6 :: "real \<Rightarrow> real"
  where "exp_cf6 \<equiv> \<lambda>x. numer_cf6 x / numer_cf6 (-x)"

lemma numer_cf6_pos: fixes x::real shows "numer_cf6 x > 0"
  unfolding numer_cf6_def
  by sturm

lemma exp_cf6_pos: "exp_cf6 x > 0"
  unfolding exp_cf6_def
  by (auto simp add: divide_simps numer_cf6_pos)

definition diff_delta_lnexp_cf6 :: "real \<Rightarrow> real"
  where "diff_delta_lnexp_cf6 \<equiv> \<lambda>x. - (x^12) / (numer_cf6 (-x) * numer_cf6 x)"

lemma d_delta_lnexp_cf6_nonpos: "diff_delta_lnexp_cf6 x \<le> 0"
  unfolding diff_delta_lnexp_cf6_def
  using numer_cf6_pos [of x]  numer_cf6_pos [of "-x"]
  by (simp add: zero_le_divide_iff zero_le_mult_iff)

lemma d_delta_lnexp_cf6:
    "((\<lambda>x. ln (exp_cf6 x) - x) has_field_derivative diff_delta_lnexp_cf6 x) (at x)"
  unfolding exp_cf6_def diff_delta_lnexp_cf6_def numer_cf6_def
  apply (intro derivative_eq_intros | simp)+
  using exp_cf6_pos
  apply (simp add: exp_cf6_def numer_cf6_def)
  apply (simp_all add: )
  using numer_cf6_pos [of x]  numer_cf6_pos [of "-x"]
  apply (auto simp: divide_simps numer_cf6_def)
  apply algebra
  done

text\<open>Upper bound for non-positive x\<close>
lemma ln_exp_cf6_upper_bound_neg:
  assumes "x \<le> 0"
    shows "x \<le> ln (exp_cf6 x)"
  by (rule gen_upper_bound_decreasing [OF assms d_delta_lnexp_cf6 d_delta_lnexp_cf6_nonpos])
     (simp add: exp_cf6_def numer_cf6_def)

theorem exp_cf6_upper_bound_neg: "x\<le>0 \<Longrightarrow> exp(x) \<le> exp_cf6 x"
  by (metis ln_exp_cf6_upper_bound_neg exp_cf6_pos exp_le_cancel_iff exp_ln_iff)

text\<open>Lower bound for non-negative x\<close>
lemma ln_exp_cf6_lower_bound_pos:
  assumes "0\<le>x"
    shows "ln (exp_cf6 x) \<le> x"
  by (rule gen_lower_bound_increasing [OF assms d_delta_lnexp_cf6 d_delta_lnexp_cf6_nonpos])
     (simp add: exp_cf6_def numer_cf6_def)

theorem exp_cf6_lower_bound_pos: "0\<le>x \<Longrightarrow> exp_cf6 x \<le> exp x"
  by (metis exp_cf6_pos exp_le_cancel_iff exp_ln ln_exp_cf6_lower_bound_pos)

section \<open>Continued Fraction Bound 7\<close>

text\<open>This bound crosses the X-axis twice, causing complications.\<close>

definition numer_cf7 :: "real \<Rightarrow> real"
  where "numer_cf7 \<equiv> \<lambda>x. x^7 + 56*x^6 + 1512*x^5 + 25200*x^4 + 277200*x^3 + 1995840*x^2 + 8648640*x + 17297280"

definition exp_cf7 :: "real \<Rightarrow> real"
  where "exp_cf7 \<equiv> \<lambda>x. numer_cf7 x / numer_cf7 (-x)"

lemma numer_cf7_pos: "-9.943 \<le> x \<Longrightarrow> numer_cf7 x > 0"
  unfolding numer_cf7_def
  by sturm

lemma exp_cf7_pos: "numer_cf7 x > 0 \<Longrightarrow> numer_cf7 (-x) > 0 \<Longrightarrow> exp_cf7 x > 0"
  by (simp add: exp_cf7_def)

definition diff_delta_lnexp_cf7 :: "real \<Rightarrow> real"
  where "diff_delta_lnexp_cf7 \<equiv> \<lambda>x. (x^14) / (numer_cf7 (-x) * numer_cf7 x)"

lemma d_delta_lnexp_cf7_nonneg: "numer_cf7 x > 0 \<Longrightarrow> numer_cf7 (-x) > 0 \<Longrightarrow> diff_delta_lnexp_cf7 x \<ge> 0"
  unfolding diff_delta_lnexp_cf7_def
  by (auto simp: mult_less_0_iff intro: divide_nonneg_neg)

lemma d_delta_lnexp_cf7:
  assumes "numer_cf7 x > 0" "numer_cf7 (-x) > 0"
  shows "((\<lambda>x. ln (exp_cf7 x) - x) has_field_derivative diff_delta_lnexp_cf7 x) (at x)"
unfolding exp_cf7_def numer_cf7_def diff_delta_lnexp_cf7_def
apply (intro derivative_eq_intros | simp)+
using assms numer_cf7_pos [of x] numer_cf7_pos [of "-x"]
apply (auto simp: numer_cf7_def)
apply (auto simp: divide_simps add_nonneg_eq_0_iff)
apply algebra
done

subsection\<open>Proving monotonicity via a non-negative derivative\<close>

definition numer_cf7_deriv :: "real \<Rightarrow> real"
  where "numer_cf7_deriv \<equiv> \<lambda>x. 7*x^6 + 336*x^5 + 7560*x^4 + 100800*x^3 + 831600*x^2 + 3991680*x + 8648640"

lemma numer_cf7_deriv:
  shows "(numer_cf7 has_field_derivative numer_cf7_deriv x) (at x)"
  unfolding numer_cf7_def numer_cf7_deriv_def
  by (intro derivative_eq_intros | simp)+

lemma numer_cf7_deriv_pos: "numer_cf7_deriv x \<ge> 0"
  unfolding numer_cf7_deriv_def
  apply (rule order.strict_implies_order)  \<comment> \<open>FIXME should not be necessary\<close>
  by sturm

lemma numer_cf7_mono: "y \<le> x \<Longrightarrow> numer_cf7 y \<le> numer_cf7 x"
  by (auto intro: DERIV_nonneg_imp_nondecreasing numer_cf7_deriv numer_cf7_deriv_pos)

subsection\<open>Results\<close>

text\<open>Upper bound for non-negative x\<close>
lemma ln_exp_cf7_upper_bound_nonneg:
  assumes x0: "0 \<le> x" and xless: "numer_cf7 (-x) > 0"
    shows "x \<le> ln (exp_cf7 x)"
proof -
  have ncf7: "\<And>y. 0 \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> numer_cf7 (-y) > 0"
    by (metis neg_le_iff_le numer_cf7_mono order.strict_trans2 xless)
  show ?thesis
    apply (rule gen_upper_bound_increasing [OF x0 d_delta_lnexp_cf7 d_delta_lnexp_cf7_nonneg])
    apply (auto simp add: ncf7 assms numer_cf7_pos)
    apply (simp add: exp_cf7_def numer_cf7_def)
    done
qed

theorem exp_cf7_upper_bound_pos: "0 \<le> x \<Longrightarrow> numer_cf7 (-x) > 0 \<Longrightarrow> exp x \<le> exp_cf7 x"
  using ln_exp_cf7_upper_bound_nonneg [of x] exp_cf7_pos [of x] numer_cf7_pos [of x]
  by auto (metis exp_le_cancel_iff exp_ln_iff)

corollary "0 \<le> x \<Longrightarrow> x \<le> 9.943 \<Longrightarrow> exp x \<le> exp_cf7 x"
  by (metis neg_le_iff_le numer_cf7_pos exp_cf7_upper_bound_pos)

text\<open>Lower bound for negative x, provided @{term"exp_cf7 x > 0"}]\<close>
lemma ln_exp_cf7_lower_bound_neg:
  assumes x0: "x \<le> 0" and xgtr: "numer_cf7 x > 0"
    shows "ln (exp_cf7 x) \<le> x"
proof -
  have ncf7: "\<And>y. x \<le> y \<Longrightarrow> y \<le> 0 \<Longrightarrow> numer_cf7 y > 0"
    by (metis dual_order.strict_trans1 numer_cf7_mono xgtr)
  show ?thesis
    apply (rule gen_lower_bound_decreasing [OF x0 d_delta_lnexp_cf7 d_delta_lnexp_cf7_nonneg])
    apply (auto simp add: ncf7 assms numer_cf7_pos)
    apply (simp add: exp_cf7_def numer_cf7_def)
    done
qed

theorem exp_cf7_lower_bound_pos:
  assumes "x \<le> 0" shows "exp_cf7 x \<le> exp x"
proof (cases "numer_cf7 x > 0")
  case True
  then have "exp_cf7 x > 0"
    using assms numer_cf7_pos [of "-x"]
    by (auto simp: exp_cf7_pos)
  then show ?thesis
  using ln_exp_cf7_lower_bound_neg [of x] assms True
    by auto (metis exp_le_cancel_iff exp_ln_iff)
next
  case False
  then have "exp_cf7 x \<le> 0"
    using assms numer_cf7_pos [of "-x"]
    unfolding exp_cf7_def
    by (simp add: divide_nonpos_pos)
  then show ?thesis
    by (metis exp_ge_zero order.trans)
qed

end


theory Tarski_Query_Impl imports
  Pseudo_Remainder_Sequence Sturm_Tarski
begin

section \<open>TaQ for polynomials with rational coefficients\<close>

global_interpretation rat_int:hom_pseudo_smods rat_of_int real_of_int real_of_rat
  defines
    ri_changes_hpoly_at  = rat_int.changes_hpoly_at and
    ri_changes_itv_spmods = rat_int.changes_itv_spmods and
    ri_changes_gt_spmods = rat_int.changes_gt_spmods and
    ri_changes_le_spmods = rat_int.changes_le_spmods and
    ri_changes_R_spmods = rat_int.changes_R_spmods
  apply unfold_locales
  by (simp_all add: of_rat_less of_rat_less_eq)

definition TaQ_R_rats::"rat poly \<Rightarrow> rat poly \<Rightarrow> int" where
  "TaQ_R_rats p q = taq {x. poly (map_poly real_of_rat p) x = (0::real)}
                                      (map_poly real_of_rat q)"

definition TaQ_itv_rats::"rat \<Rightarrow> rat \<Rightarrow> rat poly \<Rightarrow> rat poly \<Rightarrow> int" where
  "TaQ_itv_rats a b p q = taq {x. poly (map_poly real_of_rat p) x = (0::real)
        \<and> of_rat a < x \<and> x < of_rat b} (map_poly real_of_rat q)"

definition TaQ_gt_rats::" rat \<Rightarrow> rat poly \<Rightarrow> rat poly \<Rightarrow> int" where
  "TaQ_gt_rats a p q = taq {x. poly (map_poly real_of_rat p) x = (0::real)
        \<and> of_rat a < x } (map_poly real_of_rat q)"

definition TaQ_le_rats::"rat \<Rightarrow> rat poly \<Rightarrow> rat poly \<Rightarrow> int" where
  "TaQ_le_rats b p q = taq {x. poly (map_poly real_of_rat p) x = (0::real)
        \<and> x < of_rat b} (map_poly real_of_rat q)"

lemma taq_smult_pos:
  assumes "a>0"
  shows "taq s (smult a p) = taq s p"
  unfolding taq_def by (simp add: assms sign_times)

lemma taq_proots_R_code[code]:
  "TaQ_R_rats p q = (let
    ip = clear_de p;
    iq = clear_de q
    in ri_changes_R_spmods ip (pderiv ip * iq))"
proof -
  define ip iq where "ip = clear_de p" and "iq = clear_de q"
  define dp dq where "dp = rat_of_int (de_lcm p)" and "dq = rat_of_int (de_lcm q)"

  have "dp > 0" "dq>0"
    unfolding dp_def dq_def by simp_all
  have ip:"of_int_poly ip = smult dp p" and iq:"of_int_poly iq = smult dq q"
    using clear_de unfolding ip_def iq_def dp_def dq_def by auto

  have "TaQ_R_rats p q = taq {x. poly (map_poly real_of_rat (of_int_poly ip)) x = 0}
        (map_poly real_of_rat (of_int_poly iq))"
    unfolding TaQ_R_rats_def ip iq  using \<open>dp > 0\<close> \<open>dq >0\<close>
    by (simp add:of_rat_hom.map_poly_hom_smult taq_smult_pos)
  also have "... = taq {x. poly (of_int_poly ip) x = (0::real)} (of_int_poly iq)"
    by (simp add:map_poly_map_poly comp_def)
  also have "... = changes_R_smods (of_int_poly ip) (pderiv (of_int_poly ip) * of_int_poly iq)"
    using sturm_tarski_R by simp
  also have "... = changes_R_smods (of_int_poly ip) (of_int_poly (pderiv ip * iq))"
    by (simp add: of_int_hom.map_poly_pderiv of_int_poly_hom.hom_mult)
  also have "... = ri_changes_R_spmods ip (pderiv ip * iq)"
    using rat_int.changes_spmods_smods by simp
  finally have "TaQ_R_rats p q = ri_changes_R_spmods ip (pderiv ip * iq) " .
  then show ?thesis unfolding Let_def ip_def iq_def .
qed

lemma taq_proots_itv_code[code]:
  "TaQ_itv_rats a b p q = (if a\<ge>b then
      0
    else if poly p a \<noteq> 0 \<and> poly p b \<noteq>0 then
      (let
      ip = clear_de p;
      iq = clear_de q
      in ri_changes_itv_spmods a b ip (pderiv ip * iq))
    else
       Code.abort (STR ''Roots at border yet to be supported'')
                              (\<lambda>_. TaQ_itv_rats a b p q)
    )"
proof (cases "a\<ge>b \<or> poly p a = 0 \<or> poly p b = 0")
  case True
  moreover have ?thesis if "a\<ge>b"
  proof -
    have "{x. poly (map_poly of_rat p) x = 0 \<and> real_of_rat a < x \<and> x < real_of_rat b}
            = {}"
      using that rat_int.r2.hom_less_eq by fastforce
    then have "TaQ_itv_rats a b p q  = taq {} (map_poly real_of_rat q)"
      unfolding TaQ_itv_rats_def by metis
    also have "... = 0"
      unfolding taq_def by simp
    finally show ?thesis using that by auto
  qed
  moreover have ?thesis if "\<not> a\<ge>b" "poly p a = 0 \<or> poly p b = 0"
    using that by auto
  ultimately show ?thesis by auto
next
  case False

  define ip iq where "ip = clear_de p" and "iq = clear_de q"
  define dp dq where "dp = rat_of_int (de_lcm p)" and "dq = rat_of_int (de_lcm q)"
  define aa bb where "aa = real_of_rat a" and "bb = real_of_rat b"

  have "dp > 0" "dq>0"
    unfolding dp_def dq_def by simp_all
  have ip:"of_int_poly ip = smult dp p" and iq:"of_int_poly iq = smult dq q"
    using clear_de unfolding ip_def iq_def dp_def dq_def by auto

  have "TaQ_itv_rats a b p q = taq {x. poly (map_poly real_of_rat (of_int_poly ip)) x = 0
        \<and> aa < x \<and> x < bb}
        (map_poly real_of_rat (of_int_poly iq))"
    unfolding TaQ_itv_rats_def ip iq aa_def bb_def  using \<open>dp > 0\<close> \<open>dq >0\<close>
    by (simp add:of_rat_hom.map_poly_hom_smult taq_smult_pos)
  also have "... = taq {x. poly (of_int_poly ip) x = (0::real)
        \<and> aa < x \<and> x < bb} (of_int_poly iq)"
    by (simp add:map_poly_map_poly comp_def)
  also have "... = changes_itv_smods aa bb (of_int_poly ip)
      (pderiv (of_int_poly ip) * of_int_poly iq)"
  proof -
    have "aa < bb" "poly (map_poly of_int ip) aa \<noteq> 0"
        "poly (map_poly of_int ip) bb \<noteq> 0"
      unfolding aa_def bb_def
      subgoal by (meson False not_less of_rat_less)
      subgoal using False \<open>0 < dp\<close> ip rat_int.map_poly_R_hom_commute by force
      subgoal using False \<open>0 < dp\<close> ip rat_int.map_poly_R_hom_commute by force
      done
    from sturm_tarski_interval[OF this]
    show ?thesis by auto
  qed
  also have "... = changes_itv_smods aa bb (of_int_poly ip) (of_int_poly (pderiv ip * iq))"
    by (simp add: of_int_hom.map_poly_pderiv of_int_poly_hom.hom_mult)
  also have "... = ri_changes_itv_spmods a b ip (pderiv ip * iq)"
    using rat_int.changes_spmods_smods unfolding aa_def bb_def by simp
  finally have "TaQ_itv_rats a b p q = ri_changes_itv_spmods a b ip (pderiv ip * iq) " .
  then show ?thesis unfolding Let_def ip_def iq_def using False by presburger
qed

lemma taq_proots_gt_code[code]:
  "TaQ_gt_rats a p q = (
    if poly p a \<noteq> 0 then
      (let
      ip = clear_de p;
      iq = clear_de q
      in ri_changes_gt_spmods a ip (pderiv ip * iq))
    else
       Code.abort (STR ''Roots at border yet to be supported'')
                              (\<lambda>_. TaQ_gt_rats a p q)
    )"
proof (cases "poly p a = 0")
  case True
  then show ?thesis by auto
next
  case False

  define ip iq where "ip = clear_de p" and "iq = clear_de q"
  define dp dq where "dp = rat_of_int (de_lcm p)" and "dq = rat_of_int (de_lcm q)"
  define aa where "aa = real_of_rat a"

  have "dp > 0" "dq>0"
    unfolding dp_def dq_def by simp_all
  have ip:"of_int_poly ip = smult dp p" and iq:"of_int_poly iq = smult dq q"
    using clear_de unfolding ip_def iq_def dp_def dq_def by auto

  have "TaQ_gt_rats a p q = taq {x. poly (map_poly real_of_rat (of_int_poly ip)) x = 0
        \<and> aa < x}
        (map_poly real_of_rat (of_int_poly iq))"
    unfolding TaQ_gt_rats_def ip iq aa_def  using \<open>dp > 0\<close> \<open>dq >0\<close>
    by (simp add:of_rat_hom.map_poly_hom_smult taq_smult_pos)
  also have "... = taq {x. poly (of_int_poly ip) x = (0::real)
        \<and> aa < x } (of_int_poly iq)"
    by (simp add:map_poly_map_poly comp_def)
  also have "... = changes_gt_smods aa (of_int_poly ip)
      (pderiv (of_int_poly ip) * of_int_poly iq)"
  proof -
    have "poly (map_poly of_int ip) aa \<noteq> 0"
      unfolding aa_def using False \<open>0 < dp\<close> ip rat_int.map_poly_R_hom_commute by force
    from sturm_tarski_above[OF this]
    show ?thesis by auto
  qed
  also have "... = changes_gt_smods aa (of_int_poly ip) (of_int_poly (pderiv ip * iq))"
    by (simp add: of_int_hom.map_poly_pderiv of_int_poly_hom.hom_mult)
  also have "... = ri_changes_gt_spmods a ip (pderiv ip * iq)"
    using rat_int.changes_spmods_smods unfolding aa_def by simp
  finally have "TaQ_gt_rats a p q = ri_changes_gt_spmods a ip (pderiv ip * iq) " .
  then show ?thesis unfolding Let_def ip_def iq_def using False by presburger
qed

lemma taq_proots_le_code[code]:
  "TaQ_le_rats b p q = (
    if poly p b \<noteq>0 then
      (let
      ip = clear_de p;
      iq = clear_de q
      in ri_changes_le_spmods b ip (pderiv ip * iq))
    else
       Code.abort (STR ''Roots at border yet to be supported'')
                              (\<lambda>_. TaQ_le_rats b p q)
    )"
proof (cases "poly p b = 0")
  case True
  then show ?thesis by auto
next
  case False

  define ip iq where "ip = clear_de p" and "iq = clear_de q"
  define dp dq where "dp = rat_of_int (de_lcm p)" and "dq = rat_of_int (de_lcm q)"
  define bb where "bb = real_of_rat b"

  have "dp > 0" "dq>0"
    unfolding dp_def dq_def by simp_all
  have ip:"of_int_poly ip = smult dp p" and iq:"of_int_poly iq = smult dq q"
    using clear_de unfolding ip_def iq_def dp_def dq_def by auto

  have "TaQ_le_rats b p q = taq {x. poly (map_poly real_of_rat (of_int_poly ip)) x = 0
        \<and> x < bb}
        (map_poly real_of_rat (of_int_poly iq))"
    unfolding TaQ_le_rats_def ip iq bb_def  using \<open>dp > 0\<close> \<open>dq >0\<close>
    by (simp add:of_rat_hom.map_poly_hom_smult taq_smult_pos)
  also have "... = taq {x. poly (of_int_poly ip) x = (0::real)
        \<and> x < bb} (of_int_poly iq)"
    by (simp add:map_poly_map_poly comp_def)
  also have "... = changes_le_smods bb (of_int_poly ip)
      (pderiv (of_int_poly ip) * of_int_poly iq)"
  proof -
    have "poly (map_poly of_int ip) bb \<noteq> 0"
      unfolding bb_def using False \<open>0 < dp\<close> ip rat_int.map_poly_R_hom_commute by force
    from sturm_tarski_below[OF this]
    show ?thesis by auto
  qed
  also have "... = changes_le_smods bb (of_int_poly ip) (of_int_poly (pderiv ip * iq))"
    by (simp add: of_int_hom.map_poly_pderiv of_int_poly_hom.hom_mult)
  also have "... = ri_changes_le_spmods b ip (pderiv ip * iq)"
    using rat_int.changes_spmods_smods unfolding bb_def by simp
  finally have "TaQ_le_rats b p q = ri_changes_le_spmods b ip (pderiv ip * iq) " .
  then show ?thesis unfolding Let_def ip_def iq_def using False by presburger
qed

end


section \<open> Sequent Calculus \<close>

theory utp_sequent
  imports utp_pred_laws
begin

definition sequent :: "'\<alpha> upred \<Rightarrow> '\<alpha> upred \<Rightarrow> bool" (infixr "\<tturnstile>" 15) where
[upred_defs]: "sequent P Q = (Q \<sqsubseteq> P)"

abbreviation sequent_triv ("\<tturnstile> _" [15] 15) where "\<tturnstile> P \<equiv> (true \<tturnstile> P)"

translations
  "\<tturnstile> P" <= "true \<tturnstile> P"

lemma sTrue: "P \<tturnstile> true"
  by pred_auto

lemma sAx: "P \<tturnstile> P"
  by pred_auto

lemma sNotI: "\<Gamma> \<and> P \<tturnstile> false \<Longrightarrow> \<Gamma> \<tturnstile> \<not> P"
  by pred_auto

lemma sConjI: "\<lbrakk> \<Gamma> \<tturnstile> P; \<Gamma> \<tturnstile> Q \<rbrakk> \<Longrightarrow> \<Gamma> \<tturnstile> P \<and> Q"
  by pred_auto

lemma sImplI: "\<lbrakk> (\<Gamma> \<and> P) \<tturnstile> Q \<rbrakk> \<Longrightarrow> \<Gamma> \<tturnstile> (P \<Rightarrow> Q)"
  by pred_auto

end


theory ch32
imports Main
begin

(* HINT FOR ONLINE DEMO
   Start your first proof attempt with
   itrev xs [] = rev xs
   then generalize by introducing ys, and finally quantify over ys.
   Each generalization should be motivated by the previous failed
   proof attempt.
   This example can also be found in the Isabelle/HOL tutorial.
*)

primrec itrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"itrev [] ys = ys" |
"itrev (x#xs) ys = itrev xs (x#ys)"

lemma "itrev xs ys = rev xs @ ys"
apply(induct xs arbitrary: ys)
apply(auto)
done

end


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

section {* Module types and modules *}

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

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

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

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

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

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

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

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

definition "ignore x y == y"

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

ML_file "modules.ML"

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

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

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

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

thm MT_def

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

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

thm MT2_b_mk_map_def MT2.mk_map_def

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

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

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

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

ML {* @{thm mt2_b_def} *}

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

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

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

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

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

sorry

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

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

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

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

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

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

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

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

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

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

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

lemma "has_module_type M MT" sorry
end

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

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

should give a comprehensible error
*)

end