section \<open>Lerch Lemma\<close>
theory Lerch_Lemma
  imports
     "HOL-Analysis.Analysis"
begin

text \<open>The main tool to prove uniqueness of the Laplace transform.\<close>

lemma lerch_lemma_real:
  fixes h::"real \<Rightarrow> real"
  assumes h_cont[continuous_intros]: "continuous_on {0 .. 1} h"
  assumes int_0: "\<And>n. ((\<lambda>u. u ^ n * h u) has_integral 0) {0 .. 1}"
  assumes u: "0 \<le> u" "u \<le> 1"
  shows "h u = 0"
proof -
  from Stone_Weierstrass_uniform_limit[OF compact_Icc h_cont]
  obtain g where g: "uniform_limit {0..1} g h sequentially" "polynomial_function (g n)" for n
    by blast
  then have rpf_g: "real_polynomial_function (g n)" for n
    by (simp add: real_polynomial_function_eq)

  let ?P = "\<lambda>n x. h x * g n x"
  have continuous_on_g[continuous_intros]: "continuous_on s (g n)" for s n
    by (rule continuous_on_polymonial_function) fact
  have P_cont: "continuous_on {0 .. 1} (?P n)" for n
    by (auto intro!: continuous_intros)
  have "uniform_limit {0 .. 1} (\<lambda>n x. h x * g n x) (\<lambda>x. h x * h x) sequentially"
    by (auto intro!: uniform_limit_intros g assms compact_imp_bounded compact_continuous_image)

  from uniform_limit_integral[OF this P_cont]
  obtain I J where
    I: "(\<And>n. (?P n has_integral I n) {0..1})"
    and J: "((\<lambda>x. h x * h x) has_integral J) {0..1}"
    and IJ: "I \<longlonglongrightarrow> J"
    by auto

  have "(?P n has_integral 0) {0..1}" for n
  proof -
    from real_polynomial_function_imp_sum[OF rpf_g]
    obtain gn ga where "g n = (\<lambda>x. \<Sum>i\<le>gn. ga i * x ^ i)" by metis
    then have "?P n x = (\<Sum>i\<le>gn. x ^ i * h x * ga i)" for x
      by (auto simp: sum_distrib_left algebra_simps)
    moreover have "((\<lambda>x. \<dots> x) has_integral 0) {0 .. 1}"
      by (auto intro!: has_integral_sum[THEN has_integral_eq_rhs] has_integral_mult_left assms)
    ultimately show ?thesis by simp
  qed
  with I have "I n = 0" for n
    using has_integral_unique by blast
  with IJ J have "((\<lambda>x. h x * h x) has_integral 0) (cbox 0 1)"
    by (metis (full_types) LIMSEQ_le_const LIMSEQ_le_const2 box_real(2) dual_order.antisym order_refl)
  with _ _ have "h u * h u = 0"
    by (rule has_integral_0_cbox_imp_0) (auto intro!: continuous_intros u)
  then show "h u = 0"
    by simp
qed

lemma lerch_lemma:
  fixes h::"real \<Rightarrow> 'a::euclidean_space"
  assumes [continuous_intros]: "continuous_on {0 .. 1} h"
  assumes int_0: "\<And>n. ((\<lambda>u. u ^ n *\<^sub>R h u) has_integral 0) {0 .. 1}"
  assumes u: "0 \<le> u" "u \<le> 1"
  shows "h u = 0"
proof (rule euclidean_eqI)
  fix b::'a assume "b \<in> Basis"
  have "continuous_on {0 .. 1} (\<lambda>x. h x \<bullet> b)"
    by (auto intro!: continuous_intros)
  moreover
  from \<open>b \<in> Basis\<close> have "((\<lambda>u. u ^ n * (h u \<bullet> b)) has_integral 0) {0 .. 1}" for n
    using int_0[of n] has_integral_componentwise_iff[of "\<lambda>u. u ^ n *\<^sub>R h u" 0 "{0 .. 1}"]
    by auto
  moreover note u
  ultimately show "h u \<bullet> b = 0 \<bullet> b"
    unfolding inner_zero_left
    by (rule lerch_lemma_real)
qed

end


(* Author: Tobias Nipkow *)
(* Todo: minimal ipl of balanced trees *)

section \<open>Binary Tree\<close>

theory Tree
imports Main
begin

datatype 'a tree =
  Leaf ("\<langle>\<rangle>") |
  Node "'a tree" ("value": 'a) "'a tree" ("(1\<langle>_,/ _,/ _\<rangle>)")
datatype_compat tree

primrec left :: "'a tree \<Rightarrow> 'a tree" where
"left (Node l v r) = l" |
"left Leaf = Leaf"

primrec right :: "'a tree \<Rightarrow> 'a tree" where
"right (Node l v r) = r" |
"right Leaf = Leaf"

text\<open>Counting the number of leaves rather than nodes:\<close>

fun size1 :: "'a tree \<Rightarrow> nat" where
"size1 \<langle>\<rangle> = 1" |
"size1 \<langle>l, x, r\<rangle> = size1 l + size1 r"

fun subtrees :: "'a tree \<Rightarrow> 'a tree set" where
"subtrees \<langle>\<rangle> = {\<langle>\<rangle>}" |
"subtrees (\<langle>l, a, r\<rangle>) = insert \<langle>l, a, r\<rangle> (subtrees l \<union> subtrees r)"

fun mirror :: "'a tree \<Rightarrow> 'a tree" where
"mirror \<langle>\<rangle> = Leaf" |
"mirror \<langle>l,x,r\<rangle> = \<langle>mirror r, x, mirror l\<rangle>"

class height = fixes height :: "'a \<Rightarrow> nat"

instantiation tree :: (type)height
begin

fun height_tree :: "'a tree => nat" where
"height Leaf = 0" |
"height (Node l a r) = max (height l) (height r) + 1"

instance ..

end

fun min_height :: "'a tree \<Rightarrow> nat" where
"min_height Leaf = 0" |
"min_height (Node l _ r) = min (min_height l) (min_height r) + 1"

fun complete :: "'a tree \<Rightarrow> bool" where
"complete Leaf = True" |
"complete (Node l x r) = (complete l \<and> complete r \<and> height l = height r)"

definition balanced :: "'a tree \<Rightarrow> bool" where
"balanced t = (height t - min_height t \<le> 1)"

text \<open>Weight balanced:\<close>
fun wbalanced :: "'a tree \<Rightarrow> bool" where
"wbalanced Leaf = True" |
"wbalanced (Node l x r) = (abs(int(size l) - int(size r)) \<le> 1 \<and> wbalanced l \<and> wbalanced r)"

text \<open>Internal path length:\<close>
fun ipl :: "'a tree \<Rightarrow> nat" where
"ipl Leaf = 0 " |
"ipl (Node l _ r) = ipl l + size l + ipl r + size r"

fun preorder :: "'a tree \<Rightarrow> 'a list" where
"preorder \<langle>\<rangle> = []" |
"preorder \<langle>l, x, r\<rangle> = x # preorder l @ preorder r"

fun inorder :: "'a tree \<Rightarrow> 'a list" where
"inorder \<langle>\<rangle> = []" |
"inorder \<langle>l, x, r\<rangle> = inorder l @ [x] @ inorder r"

text\<open>A linear version avoiding append:\<close>
fun inorder2 :: "'a tree \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"inorder2 \<langle>\<rangle> xs = xs" |
"inorder2 \<langle>l, x, r\<rangle> xs = inorder2 l (x # inorder2 r xs)"

fun postorder :: "'a tree \<Rightarrow> 'a list" where
"postorder \<langle>\<rangle> = []" |
"postorder \<langle>l, x, r\<rangle> = postorder l @ postorder r @ [x]"

text\<open>Binary Search Tree:\<close>
fun bst_wrt :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a tree \<Rightarrow> bool" where
"bst_wrt P \<langle>\<rangle> \<longleftrightarrow> True" |
"bst_wrt P \<langle>l, a, r\<rangle> \<longleftrightarrow>
 bst_wrt P l \<and> bst_wrt P r \<and> (\<forall>x\<in>set_tree l. P x a) \<and> (\<forall>x\<in>set_tree r. P a x)"

abbreviation bst :: "('a::linorder) tree \<Rightarrow> bool" where
"bst \<equiv> bst_wrt (<)"

fun (in linorder) heap :: "'a tree \<Rightarrow> bool" where
"heap Leaf = True" |
"heap (Node l m r) =
  (heap l \<and> heap r \<and> (\<forall>x \<in> set_tree l \<union> set_tree r. m \<le> x))"

subsection \<open>\<^const>\<open>map_tree\<close>\<close>

lemma eq_map_tree_Leaf[simp]: "map_tree f t = Leaf \<longleftrightarrow> t = Leaf"
by (rule tree.map_disc_iff)

lemma eq_Leaf_map_tree[simp]: "Leaf = map_tree f t \<longleftrightarrow> t = Leaf"
by (cases t) auto

subsection \<open>\<^const>\<open>size\<close>\<close>

lemma size1_size: "size1 t = size t + 1"
by (induction t) simp_all

lemma size1_ge0[simp]: "0 < size1 t"
by (simp add: size1_size)

lemma eq_size_0[simp]: "size t = 0 \<longleftrightarrow> t = Leaf"
by(cases t) auto

lemma eq_0_size[simp]: "0 = size t \<longleftrightarrow> t = Leaf"
by(cases t) auto

lemma neq_Leaf_iff: "(t \<noteq> \<langle>\<rangle>) = (\<exists>l a r. t = \<langle>l, a, r\<rangle>)"
by (cases t) auto

lemma size_map_tree[simp]: "size (map_tree f t) = size t"
by (induction t) auto

lemma size1_map_tree[simp]: "size1 (map_tree f t) = size1 t"
by (simp add: size1_size)

subsection \<open>\<^const>\<open>set_tree\<close>\<close>

lemma eq_set_tree_empty[simp]: "set_tree t = {} \<longleftrightarrow> t = Leaf"
by (cases t) auto

lemma eq_empty_set_tree[simp]: "{} = set_tree t \<longleftrightarrow> t = Leaf"
by (cases t) auto

lemma finite_set_tree[simp]: "finite(set_tree t)"
by(induction t) auto

subsection \<open>\<^const>\<open>subtrees\<close>\<close>

lemma neq_subtrees_empty[simp]: "subtrees t \<noteq> {}"
by (cases t)(auto)

lemma neq_empty_subtrees[simp]: "{} \<noteq> subtrees t"
by (cases t)(auto)

lemma set_treeE: "a \<in> set_tree t \<Longrightarrow> \<exists>l r. \<langle>l, a, r\<rangle> \<in> subtrees t"
by (induction t)(auto)

lemma Node_notin_subtrees_if[simp]: "a \<notin> set_tree t \<Longrightarrow> Node l a r \<notin> subtrees t"
by (induction t) auto

lemma in_set_tree_if: "\<langle>l, a, r\<rangle> \<in> subtrees t \<Longrightarrow> a \<in> set_tree t"
by (metis Node_notin_subtrees_if)

subsection \<open>\<^const>\<open>height\<close> and \<^const>\<open>min_height\<close>\<close>

lemma eq_height_0[simp]: "height t = 0 \<longleftrightarrow> t = Leaf"
by(cases t) auto

lemma eq_0_height[simp]: "0 = height t \<longleftrightarrow> t = Leaf"
by(cases t) auto

lemma height_map_tree[simp]: "height (map_tree f t) = height t"
by (induction t) auto

lemma height_le_size_tree: "height t \<le> size (t::'a tree)"
by (induction t) auto

lemma size1_height: "size1 t \<le> 2 ^ height (t::'a tree)"
proof(induction t)
  case (Node l a r)
  show ?case
  proof (cases "height l \<le> height r")
    case True
    have "size1(Node l a r) = size1 l + size1 r" by simp
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height r" using Node.IH by arith
    also have "\<dots> \<le> 2 ^ height r + 2 ^ height r" using True by simp
    also have "\<dots> = 2 ^ height (Node l a r)"
      using True by (auto simp: max_def mult_2)
    finally show ?thesis .
  next
    case False
    have "size1(Node l a r) = size1 l + size1 r" by simp
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height r" using Node.IH by arith
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height l" using False by simp
    finally show ?thesis using False by (auto simp: max_def mult_2)
  qed
qed simp

corollary size_height: "size t \<le> 2 ^ height (t::'a tree) - 1"
using size1_height[of t, unfolded size1_size] by(arith)

lemma height_subtrees: "s \<in> subtrees t \<Longrightarrow> height s \<le> height t"
by (induction t) auto

lemma min_height_le_height: "min_height t \<le> height t"
by(induction t) auto

lemma min_height_map_tree[simp]: "min_height (map_tree f t) = min_height t"
by (induction t) auto

lemma min_height_size1: "2 ^ min_height t \<le> size1 t"
proof(induction t)
  case (Node l a r)
  have "(2::nat) ^ min_height (Node l a r) \<le> 2 ^ min_height l + 2 ^ min_height r"
    by (simp add: min_def)
  also have "\<dots> \<le> size1(Node l a r)" using Node.IH by simp
  finally show ?case .
qed simp

subsection \<open>\<^const>\<open>complete\<close>\<close>

lemma complete_iff_height: "complete t \<longleftrightarrow> (min_height t = height t)"
apply(induction t)
 apply simp
apply (simp add: min_def max_def)
by (metis le_antisym le_trans min_height_le_height)

lemma size1_if_complete: "complete t \<Longrightarrow> size1 t = 2 ^ height t"
by (induction t) auto

lemma size_if_complete: "complete t \<Longrightarrow> size t = 2 ^ height t - 1"
using size1_if_complete[simplified size1_size] by fastforce

lemma size1_height_if_incomplete:
  "\<not> complete t \<Longrightarrow> size1 t < 2 ^ height t"
proof(induction t)
  case Leaf thus ?case by simp
next
  case (Node l x r)
  have 1: ?case if h: "height l < height r"
    using h size1_height[of l] size1_height[of r] power_strict_increasing[OF h, of "2::nat"]
    by(auto simp: max_def simp del: power_strict_increasing_iff)
  have 2: ?case if h: "height l > height r"
    using h size1_height[of l] size1_height[of r] power_strict_increasing[OF h, of "2::nat"]
    by(auto simp: max_def simp del: power_strict_increasing_iff)
  have 3: ?case if h: "height l = height r" and c: "\<not> complete l"
    using h size1_height[of r] Node.IH(1)[OF c] by(simp)
  have 4: ?case if h: "height l = height r" and c: "\<not> complete r"
    using h size1_height[of l] Node.IH(2)[OF c] by(simp)
  from 1 2 3 4 Node.prems show ?case apply (simp add: max_def) by linarith
qed

lemma complete_iff_min_height: "complete t \<longleftrightarrow> (height t = min_height t)"
by(auto simp add: complete_iff_height)

lemma min_height_size1_if_incomplete:
  "\<not> complete t \<Longrightarrow> 2 ^ min_height t < size1 t"
proof(induction t)
  case Leaf thus ?case by simp
next
  case (Node l x r)
  have 1: ?case if h: "min_height l < min_height r"
    using h min_height_size1[of l] min_height_size1[of r] power_strict_increasing[OF h, of "2::nat"]
    by(auto simp: max_def simp del: power_strict_increasing_iff)
  have 2: ?case if h: "min_height l > min_height r"
    using h min_height_size1[of l] min_height_size1[of r] power_strict_increasing[OF h, of "2::nat"]
    by(auto simp: max_def simp del: power_strict_increasing_iff)
  have 3: ?case if h: "min_height l = min_height r" and c: "\<not> complete l"
    using h min_height_size1[of r] Node.IH(1)[OF c] by(simp add: complete_iff_min_height)
  have 4: ?case if h: "min_height l = min_height r" and c: "\<not> complete r"
    using h min_height_size1[of l] Node.IH(2)[OF c] by(simp add: complete_iff_min_height)
  from 1 2 3 4 Node.prems show ?case
    by (fastforce simp: complete_iff_min_height[THEN iffD1])
qed

lemma complete_if_size1_height: "size1 t = 2 ^ height t \<Longrightarrow> complete t"
using  size1_height_if_incomplete by fastforce

lemma complete_if_size1_min_height: "size1 t = 2 ^ min_height t \<Longrightarrow> complete t"
using min_height_size1_if_incomplete by fastforce

lemma complete_iff_size1: "complete t \<longleftrightarrow> size1 t = 2 ^ height t"
using complete_if_size1_height size1_if_complete by blast

subsection \<open>\<^const>\<open>balanced\<close>\<close>

lemma balanced_subtreeL: "balanced (Node l x r) \<Longrightarrow> balanced l"
by(simp add: balanced_def)

lemma balanced_subtreeR: "balanced (Node l x r) \<Longrightarrow> balanced r"
by(simp add: balanced_def)

lemma balanced_subtrees: "\<lbrakk> balanced t; s \<in> subtrees t \<rbrakk> \<Longrightarrow> balanced s"
using [[simp_depth_limit=1]]
by(induction t arbitrary: s)
  (auto simp add: balanced_subtreeL balanced_subtreeR)

text\<open>Balanced trees have optimal height:\<close>

lemma balanced_optimal:
fixes t :: "'a tree" and t' :: "'b tree"
assumes "balanced t" "size t \<le> size t'" shows "height t \<le> height t'"
proof (cases "complete t")
  case True
  have "(2::nat) ^ height t \<le> 2 ^ height t'"
  proof -
    have "2 ^ height t = size1 t"
      using True by (simp add: size1_if_complete)
    also have "\<dots> \<le> size1 t'" using assms(2) by(simp add: size1_size)
    also have "\<dots> \<le> 2 ^ height t'" by (rule size1_height)
    finally show ?thesis .
  qed
  thus ?thesis by (simp)
next
  case False
  have "(2::nat) ^ min_height t < 2 ^ height t'"
  proof -
    have "(2::nat) ^ min_height t < size1 t"
      by(rule min_height_size1_if_incomplete[OF False])
    also have "\<dots> \<le> size1 t'" using assms(2) by (simp add: size1_size)
    also have "\<dots> \<le> 2 ^ height t'"  by(rule size1_height)
    finally have "(2::nat) ^ min_height t < (2::nat) ^ height t'" .
    thus ?thesis .
  qed
  hence *: "min_height t < height t'" by simp
  have "min_height t + 1 = height t"
    using min_height_le_height[of t] assms(1) False
    by (simp add: complete_iff_height balanced_def)
  with * show ?thesis by arith
qed

subsection \<open>\<^const>\<open>wbalanced\<close>\<close>

lemma wbalanced_subtrees: "\<lbrakk> wbalanced t; s \<in> subtrees t \<rbrakk> \<Longrightarrow> wbalanced s"
using [[simp_depth_limit=1]] by(induction t arbitrary: s) auto

subsection \<open>\<^const>\<open>ipl\<close>\<close>

text \<open>The internal path length of a tree:\<close>

lemma ipl_if_complete_int:
  "complete t \<Longrightarrow> int(ipl t) = (int(height t) - 2) * 2^(height t) + 2"
apply(induction t)
 apply simp
apply simp
apply (simp add: algebra_simps size_if_complete of_nat_diff)
done

subsection "List of entries"

lemma eq_inorder_Nil[simp]: "inorder t = [] \<longleftrightarrow> t = Leaf"
by (cases t) auto

lemma eq_Nil_inorder[simp]: "[] = inorder t \<longleftrightarrow> t = Leaf"
by (cases t) auto

lemma set_inorder[simp]: "set (inorder t) = set_tree t"
by (induction t) auto

lemma set_preorder[simp]: "set (preorder t) = set_tree t"
by (induction t) auto

lemma set_postorder[simp]: "set (postorder t) = set_tree t"
by (induction t) auto

lemma length_preorder[simp]: "length (preorder t) = size t"
by (induction t) auto

lemma length_inorder[simp]: "length (inorder t) = size t"
by (induction t) auto

lemma length_postorder[simp]: "length (postorder t) = size t"
by (induction t) auto

lemma preorder_map: "preorder (map_tree f t) = map f (preorder t)"
by (induction t) auto

lemma inorder_map: "inorder (map_tree f t) = map f (inorder t)"
by (induction t) auto

lemma postorder_map: "postorder (map_tree f t) = map f (postorder t)"
by (induction t) auto

lemma inorder2_inorder: "inorder2 t xs = inorder t @ xs"
by (induction t arbitrary: xs) auto

subsection \<open>Binary Search Tree\<close>

lemma bst_wrt_mono: "(\<And>x y. P x y \<Longrightarrow> Q x y) \<Longrightarrow> bst_wrt P t \<Longrightarrow> bst_wrt Q t"
by (induction t) (auto)

lemma bst_wrt_le_if_bst: "bst t \<Longrightarrow> bst_wrt (\<le>) t"
using bst_wrt_mono less_imp_le by blast

lemma bst_wrt_le_iff_sorted: "bst_wrt (\<le>) t \<longleftrightarrow> sorted (inorder t)"
apply (induction t)
 apply(simp)
by (fastforce simp: sorted_append intro: less_imp_le less_trans)

lemma bst_iff_sorted_wrt_less: "bst t \<longleftrightarrow> sorted_wrt (<) (inorder t)"
apply (induction t)
 apply simp
apply (fastforce simp: sorted_wrt_append)
done

subsection \<open>\<^const>\<open>heap\<close>\<close>

subsection \<open>\<^const>\<open>mirror\<close>\<close>

lemma mirror_Leaf[simp]: "mirror t = \<langle>\<rangle> \<longleftrightarrow> t = \<langle>\<rangle>"
by (induction t) simp_all

lemma Leaf_mirror[simp]: "\<langle>\<rangle> = mirror t \<longleftrightarrow> t = \<langle>\<rangle>"
using mirror_Leaf by fastforce

lemma size_mirror[simp]: "size(mirror t) = size t"
by (induction t) simp_all

lemma size1_mirror[simp]: "size1(mirror t) = size1 t"
by (simp add: size1_size)

lemma height_mirror[simp]: "height(mirror t) = height t"
by (induction t) simp_all

lemma min_height_mirror [simp]: "min_height (mirror t) = min_height t"
by (induction t) simp_all

lemma ipl_mirror [simp]: "ipl (mirror t) = ipl t"
by (induction t) simp_all

lemma inorder_mirror: "inorder(mirror t) = rev(inorder t)"
by (induction t) simp_all

lemma map_mirror: "map_tree f (mirror t) = mirror (map_tree f t)"
by (induction t) simp_all

lemma mirror_mirror[simp]: "mirror(mirror t) = t"
by (induction t) simp_all

end


theory Tensor_LValues
  imports LValues_Typed Complex_Main
"HOL-ex.Sketch_and_Explore"
begin

section Matrices

(* TODO: make non-square *)
typedef 'a matrix = "UNIV::('a\<Rightarrow>'a\<Rightarrow>complex) set" by simp
setup_lifting type_definition_matrix

lift_definition tensor :: "'a matrix \<Rightarrow> 'b matrix \<Rightarrow> ('a*'b) matrix" is
  "%A B. \<lambda>(r1,r2) (c1,c2). A r1 c1 * B r2 c2" .

(* TODO associator *)
(* TODO swapper *)

instantiation matrix :: (type) ab_group_add begin
lift_definition plus_matrix :: "'a matrix \<Rightarrow> 'a matrix \<Rightarrow> 'a matrix" is "%A B i j. A i j + B i j".
lift_definition minus_matrix :: "'a matrix \<Rightarrow> 'a matrix \<Rightarrow> 'a matrix" is "%A B i j. A i j - B i j".
lift_definition uminus_matrix :: "'a matrix \<Rightarrow> 'a matrix" is "%A i j. - A i j".
lift_definition zero_matrix :: "'a matrix" is "\<lambda>i j. 0".
instance sorry
end

instantiation matrix :: (type) "one" begin
lift_definition one_matrix :: "'a matrix" is "\<lambda>i j. if i=j then 1 else 0".
instance apply intro_classes.
end

instantiation matrix :: (finite) "times" begin
lift_definition times_matrix :: "'a matrix \<Rightarrow> 'a matrix \<Rightarrow> 'a matrix" is "%A B i k. (\<Sum>j\<in>UNIV. A i j * B j k)".
instance apply intro_classes.
end

instantiation matrix :: (finite) ring_1 begin
instance apply intro_classes sorry
end

abbreviation "delta x y == (if x=y then 1 else 0)"

lift_definition matrix_on :: "'b matrix \<Rightarrow> ('a,'b) lvalue \<Rightarrow> 'a matrix" is
  "\<lambda>B x (r::'a) (c::'a). B (fst (split_memory x r)) (fst (split_memory x c))
  * delta (snd (split_memory x r)) (snd (split_memory x c))" .

lemma matrix_on_lift_left:
  assumes compat[simp]: "compatible_lvalues x y"
  defines "xy == lvalue_pair x y"
  shows "matrix_on A x = matrix_on (tensor A 1) xy"
proof (transfer fixing: x y xy, rule ext, rule ext)
  fix A :: "'b \<Rightarrow> 'b \<Rightarrow> complex" and r c

  define xrest yrest xyrest
    where "xrest m = snd (split_memory x m)"
      and "yrest m = snd (split_memory y m)"
      and "xyrest m = snd (split_memory xy m)" for m

  have [simp]: "valid_lvalue xy"
    unfolding xy_def by simp
  have [simp]: "valid_lvalue x"
    using LValues_Typed.compatible_valid1 compat by blast
  have [simp]: "valid_lvalue y"
    using LValues_Typed.compatible_valid2 compat by blast

  have [simp]: "fst (split_memory x r) = getter x r" for r
    by simp
  have [simp]: "fst (split_memory y r) = getter y r" for r
    by simp

  have [simp]: "fst (split_memory xy r) = (getter x r, getter y r)" for r
    apply (subst fst_split_memory)
    unfolding xy_def by simp_all

  have [simp]: "xrest a = xrest b \<longleftrightarrow> xyrest a = xyrest b \<and> getter y a = getter y b" for a b
    unfolding xrest_def xyrest_def xy_def
    apply (rule split_pair_eq_typed)
    by (rule compat)

  show "A (fst (split_memory x r)) (fst (split_memory x c)) *
           delta (xrest r) (xrest c)
        =
          (\<lambda>(r1, r2) (c1, c2). A r1 c1 * delta r2 c2)
              (fst (split_memory xy r))
              (fst (split_memory xy c))
           *
           delta (xyrest r) (xyrest c)"
    by simp
qed

lemma matrix_on_lift_right:
  assumes compat[simp]: "compatible_lvalues x y"
  defines "xy == lvalue_pair x y"
  shows "matrix_on A y = matrix_on (tensor 1 A) xy"
  sorry

lift_definition map_matrix :: "('b \<Rightarrow> 'a) \<Rightarrow> 'a matrix \<Rightarrow> 'b matrix" is
  "\<lambda>f A r c. A (f r) (f c)".

lift_definition matrix_in :: "'a set \<Rightarrow> 'a matrix \<Rightarrow> bool" is
  "\<lambda>S A. \<forall>r c. A r c \<noteq> 0 \<longrightarrow> r \<in> S \<and> c \<in> S".

lemma matrix_in_UNIV[simp]: "matrix_in UNIV A"
  apply transfer by simp

lift_definition split_matrix :: "('a,'b) lvalue \<Rightarrow> 'a matrix \<Rightarrow> ('b*'a memory_rest) matrix" is
  "\<lambda>x A (r,r') (c,c'). if r' \<in> memory_except x \<and> c' \<in> memory_except x
    then A (join_memory x (r,r')) (join_memory x (c,c')) else 0".

definition "join_matrix x A = map_matrix (split_memory x) A"

lemma map_mult:
  assumes inj: "inj f"
  assumes "matrix_in (range f) A"
  shows "map_matrix f A * map_matrix f B = map_matrix f (A*B)"
proof (insert assms(2), transfer fixing: f, rule ext, rule ext, rename_tac r c)
  fix A :: "'b \<Rightarrow> 'b \<Rightarrow> complex"
    and B :: "'b \<Rightarrow> 'b \<Rightarrow> complex"
    and r :: 'a
    and c :: 'a
  assume in_range: "\<forall>r c. A r c \<noteq> 0 \<longrightarrow> r \<in> range f \<and> c \<in> range f"
  show "(\<Sum>j\<in>UNIV. A (f r) (f j) * B (f j) (f c))
      = (\<Sum>j\<in>UNIV. (A (f r) j) * B j (f c))"
    apply (subst sum.reindex[OF inj, symmetric, unfolded o_def])
    apply (rule sum.mono_neutral_cong_left, auto)
    using in_range by auto
qed

(* lift_definition join_matrix :: "('a,'b) lvalue \<Rightarrow> ('b*'a memory_rest) matrix \<Rightarrow> 'a matrix" is
  "\<lambda>x A r c. A (split_memory x r) (split_memory x c)". *)

lift_definition binary_diagonal :: "'a set \<Rightarrow> 'a matrix" is
  "\<lambda>S r c. if r = c \<and> r \<in> S then 1 else 0".

lemma binary_diagonal_square[simp]:
  "binary_diagonal S * binary_diagonal T = binary_diagonal (S \<inter> T)"
proof (transfer fixing: S T , rule ext , rule ext , rename_tac r c)
  fix     r c :: 'a
  have "(\<Sum>j\<in>UNIV. (if r = j \<and> r \<in> S then 1 else (0::complex))
                * (if j = c \<and> j \<in> T then 1 else 0))
      = (\<Sum>j\<in>{r}. (if r = j \<and> r \<in> S then 1 else 0)
                * (if j = c \<and> j \<in> T then 1 else 0))"
    by (rule sum.mono_neutral_cong_right, auto)
  also have "\<dots> = (if r = c \<and> r \<in> S \<inter> T then 1 else 0)"
    apply simp by blast
  finally show "(\<Sum>j\<in>UNIV. (if r = j \<and> r \<in> S then 1::complex else 0)
                * (if j = c \<and> j \<in> T then 1 else 0))
          = (if r = c \<and> r \<in> S \<inter> T then 1 else 0)"
    by -
qed

lemma matrix_in_binary_diagonal[simp]: "matrix_in S (binary_diagonal S)"
  apply transfer by simp

definition matrix_on2 :: "'b matrix \<Rightarrow> ('a,'b) lvalue \<Rightarrow> 'a matrix" where
  "matrix_on2 A x = join_matrix x (tensor A (binary_diagonal (memory_except x)))"

lemma matrix_on2_same:
  assumes "valid_lvalue x"
  shows "matrix_on2 A x = matrix_on A x"
  unfolding matrix_on2_def join_matrix_def
  apply (transfer fixing: x, rule ext, rule ext, rename_tac r c)
  apply (auto simp: case_prod_beta)
  using assms
  by (meson LValues_Typed.split_memory_range mem_Times_iff)

lemma tensor_distrib: "(tensor A B) * (tensor C D) = tensor (A * C) (B * D)"
proof (transfer, rule ext, rule ext)
  fix A C :: "'a\<Rightarrow>'a\<Rightarrow>complex" and B D :: "'b\<Rightarrow>'b\<Rightarrow>complex" and i k :: "'a*'b"
  obtain i1 i2 k1 k2 where i: "i=(i1,i2)" and k: "k=(k1,k2)" by force
  have "(\<Sum>j\<in>UNIV.
          (case i of (r1, r2) \<Rightarrow> \<lambda>(c1, c2). A r1 c1 * B r2 c2) j *
          (case j of (r1, r2) \<Rightarrow> \<lambda>(c1, c2). C r1 c1 * D r2 c2) k)
        =
          (\<Sum>(j1,j2)\<in>UNIV. (A i1 j1 * B i2 j2) * (C j1 k1 * D j2 k2))" (is "?lhs = _")
    unfolding i k by (auto simp: case_prod_beta)
  also have "\<dots> = (\<Sum>j1\<in>UNIV. \<Sum>j2\<in>UNIV. (A i1 j1 * C j1 k1) * (B i2 j2 * D j2 k2))"
    unfolding UNIV_Times_UNIV[symmetric] sum.cartesian_product[symmetric]
    by (meson semiring_normalization_rules(13) sum.cong)
  also have "\<dots> = (\<Sum>j1\<in>UNIV. A i1 j1 * C j1 k1) * (\<Sum>j2\<in>UNIV. B i2 j2 * D j2 k2)"
    by (simp add: sum_product)
  also have "... = (case i of (r1, r2) \<Rightarrow> \<lambda>(c1, c2). (\<Sum>j\<in>UNIV. A r1 j * C j c1) * (\<Sum>j\<in>UNIV. B r2 j * D j c2)) k"  (is "_ = ?rhs")
    unfolding i k by simp
  finally
  show "?lhs = ?rhs" by assumption
qed

lemma matrix_in_tensor: "matrix_in S A \<Longrightarrow> matrix_in T B \<Longrightarrow> matrix_in (S \<times> T) (tensor A B)"
  apply (transfer fixing: S T) by auto

lemma matrix_on_times:
  fixes x :: "('a::finite,'b::finite) lvalue"
  assumes [simp]: "valid_lvalue x"
  shows "matrix_on A x * matrix_on B x = matrix_on (A*B) x"
proof -
  define spl dia where "spl = split_memory x"
    and "dia = binary_diagonal (LValues_Typed.memory_except x)"

  have inj_spl: "inj spl"
    using assms unfolding spl_def apply transfer
    apply auto
    using bij_betw_imp_inj_on bij_split_memory by fastforce

  have in_range: "matrix_in (range spl) (tensor A dia)"
    apply (simp add: split_memory_range' spl_def dia_def)
    apply (rule matrix_in_tensor)
    by auto

  have "matrix_on A x * matrix_on B x = matrix_on2 A x * matrix_on2 B x"
    apply (subst matrix_on2_same[symmetric], simp)+ by simp
  also have "\<dots> = map_matrix spl (tensor A dia) * map_matrix spl (tensor B dia)"
    unfolding matrix_on2_def join_matrix_def spl_def[symmetric] dia_def[symmetric] by rule
  also have "\<dots> = map_matrix spl (tensor A dia * tensor B dia)"
    using inj_spl in_range by (rule map_mult)
  also have "\<dots> = map_matrix spl (tensor (A * B) (dia * dia))"
    apply (subst tensor_distrib) by simp
  also have "\<dots> = map_matrix spl (tensor (A * B) dia)"
    unfolding dia_def by simp
  also have "\<dots> = matrix_on2 (A * B) x"
    unfolding matrix_on2_def join_matrix_def spl_def[symmetric] dia_def[symmetric] by rule
  also have "\<dots> = matrix_on (A * B) x"
    by (subst matrix_on2_same[symmetric], auto)
  finally show ?thesis
    by -
qed

lemma
  assumes "compatible_lvalues x y"
  defines "xy == lvalue_pair x y"
  shows "matrix_on A x * matrix_on B y = matrix_on (tensor A B) xy"
proof -
  define splx sply diax diay where "splx = split_memory x"
    and "sply = split_memory y"
    and "diax = binary_diagonal (LValues_Typed.memory_except x)"
    and "diay = binary_diagonal (LValues_Typed.memory_except y)"

  have [simp]: "valid_lvalue x" "valid_lvalue y"
    using compatible_valid1 compatible_valid2 assms(1) by blast+
  have "matrix_on A x * matrix_on B y = matrix_on2 A x * matrix_on2 B y"
    apply (subst matrix_on2_same[symmetric], simp)+ by simp
  also have "\<dots> = map_matrix splx (tensor A diax) * map_matrix sply (tensor B diay)"
    unfolding matrix_on2_def join_matrix_def splx_def[symmetric] sply_def[symmetric]
        diax_def[symmetric] diay_def[symmetric] by rule

  show ?thesis
    by -
qed

end


theory Defs
  imports "HOL-IMP.Complete_Lattice" "HOL-Library.Extended_Real" "HOL-Library.While_Combinator"
begin

section "AExp"

type_synonym vname = string
type_synonym val = "ereal option"
type_synonym state = "vname \<Rightarrow> val"

datatype aexp = N int | V vname | Plus aexp aexp

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = Some n" |
"aval (V x) s = s x" |
"aval (Plus a\<^sub>1 a\<^sub>2) s = (
   case (aval a\<^sub>1 s, aval a\<^sub>2 s) of
     (None, _) \<Rightarrow> None
   | (_, None) \<Rightarrow> None
   | (Some PInfty, Some MInfty) \<Rightarrow> None
   | (Some MInfty, Some PInfty) \<Rightarrow> None
   | (Some v\<^sub>1, Some v\<^sub>2) \<Rightarrow> Some (v\<^sub>1 + v\<^sub>2)
  )"

definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

section \<open>BExp\<close>

datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool option" where
"bval (Bc v) s = Some v" |
"bval (Not b) s = map_option (HOL.Not) (bval b s)" |
"bval (And b\<^sub>1 b\<^sub>2) s = (
   case (bval b\<^sub>1 s, bval b\<^sub>2 s) of
     (None, _) \<Rightarrow> None
   | (_, None) \<Rightarrow> None
   | (Some v\<^sub>1, Some v\<^sub>2) \<Rightarrow> Some (v\<^sub>1 \<and> v\<^sub>2)
)" |
"bval (Less a\<^sub>1 a\<^sub>2) s = (
  case (aval a\<^sub>1 s, aval a\<^sub>2 s) of
    (None, _) \<Rightarrow> None |
    (_, None) \<Rightarrow> None |
    (Some v\<^sub>1, Some v\<^sub>2) \<Rightarrow> Some (v\<^sub>1 < v\<^sub>2)
)"

section \<open>Com\<close>

datatype
  com = SKIP
      | Assign vname aexp       ("_ ::= _" [1000, 61] 61)
      | Seq    com  com         ("_;;/ _"  [60, 61] 60)
      | If     bexp com com     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61)
      | While  bexp com         ("(WHILE _/ DO _)"  [0, 61] 61)

section \<open>Big_Step\<close>

inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
Skip: "(SKIP,s) \<Rightarrow> s" |
Assign: "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
IfTrue: "\<lbrakk> bval b s = Some True;  (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
IfFalse: "\<lbrakk> bval b s = Some False;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
WhileFalse: "bval b s = Some False \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
WhileTrue:
"\<lbrakk> bval b s\<^sub>1 = Some True;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
\<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3"

code_pred big_step .

declare big_step.intros [intro]
lemmas big_step_induct = big_step.induct[split_format(complete)]
inductive_cases SkipE[elim!]: "(SKIP,s) \<Rightarrow> t"
inductive_cases AssignE[elim!]: "(x ::= a,s) \<Rightarrow> t"
inductive_cases SeqE[elim!]: "(c1;;c2,s1) \<Rightarrow> s3"
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
inductive_cases WhileE[elim]: "(WHILE b DO c,s) \<Rightarrow> t"

(* Using rule inversion to prove simplification rules: *)
lemma assign_simp:
  "(x ::= a,s) \<Rightarrow> s' \<longleftrightarrow> (s' = s(x := aval a s))"
  by auto

text \<open>An example combining rule inversion and derivations\<close>
lemma Seq_assoc:
  "(c1;; c2;; c3, s) \<Rightarrow> s' \<longleftrightarrow> (c1;; (c2;; c3), s) \<Rightarrow> s'"
proof
  assume "(c1;; c2;; c3, s) \<Rightarrow> s'"
  then obtain s1 s2 where
    c1: "(c1, s) \<Rightarrow> s1" and
    c2: "(c2, s1) \<Rightarrow> s2" and
    c3: "(c3, s2) \<Rightarrow> s'" by auto
  from c2 c3
  have "(c2;; c3, s1) \<Rightarrow> s'" by (rule Seq)
  with c1
  show "(c1;; (c2;; c3), s) \<Rightarrow> s'" by (rule Seq)
next
  \<comment> \<open>The other direction is analogous\<close>
  assume "(c1;; (c2;; c3), s) \<Rightarrow> s'"
  thus "(c1;; c2;; c3, s) \<Rightarrow> s'" by auto
qed

section "ACom"

datatype 'a acom =
  SKIP 'a                           ("SKIP {_}" 61) |
  Assign vname aexp 'a              ("(_ ::= _/ {_})" [1000, 61, 0] 61) |
  Seq "('a acom)" "('a acom)"       ("_;;//_"  [60, 61] 60) |
  If bexp 'a "('a acom)" 'a "('a acom)" 'a
    ("(IF _/ THEN ({_}/ _)/ ELSE ({_}/ _)//{_})"  [0, 0, 0, 61, 0, 0] 61) |
  While 'a bexp 'a "('a acom)" 'a
    ("({_}//WHILE _//DO ({_}//_)//{_})"  [0, 0, 0, 61, 0] 61)

notation com.SKIP ("SKIP")

fun strip :: "'a acom \<Rightarrow> com" where
"strip (SKIP {P}) = SKIP" |
"strip (x ::= e {P}) = x ::= e" |
"strip (C\<^sub>1;;C\<^sub>2) = strip C\<^sub>1;; strip C\<^sub>2" |
"strip (IF b THEN {P\<^sub>1} C\<^sub>1 ELSE {P\<^sub>2} C\<^sub>2 {P}) =
  IF b THEN strip C\<^sub>1 ELSE strip C\<^sub>2" |
"strip ({I} WHILE b DO {P} C {Q}) = WHILE b DO strip C"

fun asize :: "com \<Rightarrow> nat" where
"asize SKIP = 1" |
"asize (x ::= e) = 1" |
"asize (C\<^sub>1;;C\<^sub>2) = asize C\<^sub>1 + asize C\<^sub>2" |
"asize (IF b THEN C\<^sub>1 ELSE C\<^sub>2) = asize C\<^sub>1 + asize C\<^sub>2 + 3" |
"asize (WHILE b DO C) = asize C + 3"

definition shift :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a" where
"shift f n = (\<lambda>p. f(p+n))"

fun annotate :: "(nat \<Rightarrow> 'a) \<Rightarrow> com \<Rightarrow> 'a acom" where
"annotate f SKIP = SKIP {f 0}" |
"annotate f (x ::= e) = x ::= e {f 0}" |
"annotate f (c\<^sub>1;;c\<^sub>2) = annotate f c\<^sub>1;; annotate (shift f (asize c\<^sub>1)) c\<^sub>2" |
"annotate f (IF b THEN c\<^sub>1 ELSE c\<^sub>2) =
  IF b THEN {f 0} annotate (shift f 1) c\<^sub>1
  ELSE {f(asize c\<^sub>1 + 1)} annotate (shift f (asize c\<^sub>1 + 2)) c\<^sub>2
  {f(asize c\<^sub>1 + asize c\<^sub>2 + 2)}" |
"annotate f (WHILE b DO c) =
  {f 0} WHILE b DO {f 1} annotate (shift f 2) c {f(asize c + 2)}"

fun annos :: "'a acom \<Rightarrow> 'a list" where
"annos (SKIP {P}) = [P]" |
"annos (x ::= e {P}) = [P]" |
"annos (C\<^sub>1;;C\<^sub>2) = annos C\<^sub>1 @ annos C\<^sub>2" |
"annos (IF b THEN {P\<^sub>1} C\<^sub>1 ELSE {P\<^sub>2} C\<^sub>2 {Q}) =
  P\<^sub>1 # annos C\<^sub>1 @  P\<^sub>2 # annos C\<^sub>2 @ [Q]" |
"annos ({I} WHILE b DO {P} C {Q}) = I # P # annos C @ [Q]"

definition anno :: "'a acom \<Rightarrow> nat \<Rightarrow> 'a" where
"anno C p = annos C ! p"

definition post :: "'a acom \<Rightarrow>'a" where
"post C = last(annos C)"

fun map_acom :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a acom \<Rightarrow> 'b acom" where
"map_acom f (SKIP {P}) = SKIP {f P}" |
"map_acom f (x ::= e {P}) = x ::= e {f P}" |
"map_acom f (C\<^sub>1;;C\<^sub>2) = map_acom f C\<^sub>1;; map_acom f C\<^sub>2" |
"map_acom f (IF b THEN {P\<^sub>1} C\<^sub>1 ELSE {P\<^sub>2} C\<^sub>2 {Q}) =
  IF b THEN {f P\<^sub>1} map_acom f C\<^sub>1 ELSE {f P\<^sub>2} map_acom f C\<^sub>2
  {f Q}" |
"map_acom f ({I} WHILE b DO {P} C {Q}) =
  {f I} WHILE b DO {f P} map_acom f C {f Q}"

lemma annos_ne: "annos C \<noteq> []"
by(induction C) auto

lemma strip_annotate[simp]: "strip(annotate f c) = c"
by(induction c arbitrary: f) auto

lemma length_annos_annotate[simp]: "length (annos (annotate f c)) = asize c"
by(induction c arbitrary: f) auto

lemma size_annos: "size(annos C) = asize(strip C)"
by(induction C)(auto)

lemma size_annos_same: "strip C1 = strip C2 \<Longrightarrow> size(annos C1) = size(annos C2)"
apply(induct C2 arbitrary: C1)
apply(case_tac C1, simp_all)+
done

lemmas size_annos_same2 = eqTrueI[OF size_annos_same]

lemma anno_annotate[simp]: "p < asize c \<Longrightarrow> anno (annotate f c) p = f p"
apply(induction c arbitrary: f p)
apply (auto simp: anno_def nth_append nth_Cons numeral_eq_Suc shift_def
            split: nat.split)
  apply (metis add_Suc_right add_diff_inverse add.commute)
 apply(rule_tac f=f in arg_cong)
 apply arith
apply (metis less_Suc_eq)
done

lemma eq_acom_iff_strip_annos:
  "C1 = C2 \<longleftrightarrow> strip C1 = strip C2 \<and> annos C1 = annos C2"
apply(induction C1 arbitrary: C2)
apply(case_tac C2, auto simp: size_annos_same2)+
done

lemma eq_acom_iff_strip_anno:
  "C1=C2 \<longleftrightarrow> strip C1 = strip C2 \<and> (\<forall>p<size(annos C1). anno C1 p = anno C2 p)"
by(auto simp add: eq_acom_iff_strip_annos anno_def
     list_eq_iff_nth_eq size_annos_same2)

lemma post_map_acom[simp]: "post(map_acom f C) = f(post C)"
by (induction C) (auto simp: post_def last_append annos_ne)

lemma strip_map_acom[simp]: "strip (map_acom f C) = strip C"
by (induction C) auto

lemma anno_map_acom: "p < size(annos C) \<Longrightarrow> anno (map_acom f C) p = f(anno C p)"
apply(induction C arbitrary: p)
apply(auto simp: anno_def nth_append nth_Cons' size_annos)
done

lemma strip_eq_SKIP:
  "strip C = SKIP \<longleftrightarrow> (\<exists>P. C = SKIP {P})"
by (cases C) simp_all

lemma strip_eq_Assign:
  "strip C = x::=e \<longleftrightarrow> (\<exists>P. C = x::=e {P})"
by (cases C) simp_all

lemma strip_eq_Seq:
  "strip C = c1;;c2 \<longleftrightarrow> (\<exists>C1 C2. C = C1;;C2 & strip C1 = c1 & strip C2 = c2)"
by (cases C) simp_all

lemma strip_eq_If:
  "strip C = IF b THEN c1 ELSE c2 \<longleftrightarrow>
  (\<exists>P1 P2 C1 C2 Q. C = IF b THEN {P1} C1 ELSE {P2} C2 {Q} & strip C1 = c1 & strip C2 = c2)"
by (cases C) simp_all

lemma strip_eq_While:
  "strip C = WHILE b DO c1 \<longleftrightarrow>
  (\<exists>I P C1 Q. C = {I} WHILE b DO {P} C1 {Q} & strip C1 = c1)"
by (cases C) simp_all

lemma set_annos_anno[simp]: "set (annos (annotate (\<lambda>p. a) c)) = {a}"
by(induction c) simp_all

lemma post_in_annos: "post C \<in> set(annos C)"
by(auto simp: post_def annos_ne)

lemma post_anno_asize: "post C = anno C (size(annos C) - 1)"
by(simp add: post_def last_conv_nth[OF annos_ne] anno_def)

class vars =
fixes vars :: "'a \<Rightarrow> vname set"

instantiation aexp :: vars
begin

fun vars_aexp :: "aexp \<Rightarrow> vname set" where
"vars (N n) = {}" |
"vars (V x) = {x}" |
"vars (Plus a\<^sub>1 a\<^sub>2) = vars a\<^sub>1 \<union> vars a\<^sub>2"

instance ..

end

value "vars (Plus (V ''x'') (V ''y''))"

instantiation bexp :: vars
begin

fun vars_bexp :: "bexp \<Rightarrow> vname set" where
"vars (Bc v) = {}" |
"vars (Not b) = vars b" |
"vars (And b\<^sub>1 b\<^sub>2) = vars b\<^sub>1 \<union> vars b\<^sub>2" |
"vars (Less a\<^sub>1 a\<^sub>2) = vars a\<^sub>1 \<union> vars a\<^sub>2"

instance ..

end

value "vars (Less (Plus (V ''z'') (V ''y'')) (V ''x''))"

abbreviation
  eq_on :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> bool"
 ("(_ =/ _/ on _)" [50,0,50] 50) where
"f = g on X == \<forall> x \<in> X. f x = g x"

lemma aval_eq_if_eq_on_vars[simp]:
  "s\<^sub>1 = s\<^sub>2 on vars a \<Longrightarrow> aval a s\<^sub>1 = aval a s\<^sub>2"
apply(induction a)
apply simp_all
done

lemma bval_eq_if_eq_on_vars:
  "s\<^sub>1 = s\<^sub>2 on vars b \<Longrightarrow> bval b s\<^sub>1 = bval b s\<^sub>2"
proof(induction b)
  case (Less a1 a2)
  hence "aval a1 s\<^sub>1 = aval a1 s\<^sub>2" and "aval a2 s\<^sub>1 = aval a2 s\<^sub>2" by simp_all
  thus ?case by simp
qed simp_all

fun lvars :: "com \<Rightarrow> vname set" where
"lvars SKIP = {}" |
"lvars (x::=e) = {x}" |
"lvars (c1;;c2) = lvars c1 \<union> lvars c2" |
"lvars (IF b THEN c1 ELSE c2) = lvars c1 \<union> lvars c2" |
"lvars (WHILE b DO c) = lvars c"

fun rvars :: "com \<Rightarrow> vname set" where
"rvars SKIP = {}" |
"rvars (x::=e) = vars e" |
"rvars (c1;;c2) = rvars c1 \<union> rvars c2" |
"rvars (IF b THEN c1 ELSE c2) = vars b \<union> rvars c1 \<union> rvars c2" |
"rvars (WHILE b DO c) = vars b \<union> rvars c"

instantiation com :: vars
begin

definition "vars_com c = lvars c \<union> rvars c"

instance ..

end

lemma vars_com_simps[simp]:
  "vars SKIP = {}"
  "vars (x::=e) = {x} \<union> vars e"
  "vars (c1;;c2) = vars c1 \<union> vars c2"
  "vars (IF b THEN c1 ELSE c2) = vars b \<union> vars c1 \<union> vars c2"
  "vars (WHILE b DO c) = vars b \<union> vars c"
by(auto simp: vars_com_def)

lemma finite_avars[simp]: "finite(vars(a::aexp))"
by(induction a) simp_all

lemma finite_bvars[simp]: "finite(vars(b::bexp))"
by(induction b) simp_all

lemma finite_lvars[simp]: "finite(lvars(c))"
by(induction c) simp_all

lemma finite_rvars[simp]: "finite(rvars(c))"
by(induction c) simp_all

lemma finite_cvars[simp]: "finite(vars(c::com))"
by(simp add: vars_com_def)

section \<open>Collecting\<close>
notation
  sup (infixl "\<squnion>" 65) and
  inf (infixl "\<sqinter>" 70) and
  bot ("\<bottom>") and
  top ("\<top>")

context
  fixes f :: "vname \<Rightarrow> aexp \<Rightarrow> 'a \<Rightarrow> 'a::sup"
  fixes g :: "bexp \<Rightarrow> 'a \<Rightarrow> 'a"
begin
fun Step :: "'a \<Rightarrow> 'a acom \<Rightarrow> 'a acom" where
"Step S (SKIP {Q}) = (SKIP {S})" |
"Step S (x ::= e {Q}) =
  x ::= e {f x e S}" |
"Step S (C1;; C2) = Step S C1;; Step (post C1) C2" |
"Step S (IF b THEN {P1} C1 ELSE {P2} C2 {Q}) =
  IF b THEN {g b S} Step P1 C1 ELSE {g (Not b) S} Step P2 C2
  {post C1 \<squnion> post C2}" |
"Step S ({I} WHILE b DO {P} C {Q}) =
  {S \<squnion> post C} WHILE b DO {g b I} Step P C {g (Not b) I}"
end

lemma strip_Step[simp]: "strip(Step f g S C) = strip C"
by(induct C arbitrary: S) auto

instantiation acom :: (order) order
begin

definition less_eq_acom :: "('a::order)acom \<Rightarrow> 'a acom \<Rightarrow> bool" where
"C1 \<le> C2 \<longleftrightarrow> strip C1 = strip C2 \<and> (\<forall>p<size(annos C1). anno C1 p \<le> anno C2 p)"

definition less_acom :: "'a acom \<Rightarrow> 'a acom \<Rightarrow> bool" where
"less_acom x y = (x \<le> y \<and> \<not> y \<le> x)"

instance
proof (standard, goal_cases)
  case 1 show ?case by(simp add: less_acom_def)
next
  case 2 thus ?case by(auto simp: less_eq_acom_def)
next
  case 3 thus ?case by(fastforce simp: less_eq_acom_def size_annos)
next
  case 4 thus ?case
    by(fastforce simp: le_antisym less_eq_acom_def size_annos
         eq_acom_iff_strip_anno)
qed

end

lemma less_eq_acom_annos:
  "C1 \<le> C2 \<longleftrightarrow> strip C1 = strip C2 \<and> list_all2 (\<le>) (annos C1) (annos C2)"
by(auto simp add: less_eq_acom_def anno_def list_all2_conv_all_nth size_annos_same2)

lemma SKIP_le[simp]: "SKIP {S} \<le> c \<longleftrightarrow> (\<exists>S'. c = SKIP {S'} \<and> S \<le> S')"
by (cases c) (auto simp:less_eq_acom_def anno_def)

lemma Assign_le[simp]: "x ::= e {S} \<le> c \<longleftrightarrow> (\<exists>S'. c = x ::= e {S'} \<and> S \<le> S')"
by (cases c) (auto simp:less_eq_acom_def anno_def)

lemma Seq_le[simp]: "C1;;C2 \<le> C \<longleftrightarrow> (\<exists>C1' C2'. C = C1';;C2' \<and> C1 \<le> C1' \<and> C2 \<le> C2')"
apply (cases C)
apply(auto simp: less_eq_acom_annos list_all2_append size_annos_same2)
done

lemma If_le[simp]: "IF b THEN {p1} C1 ELSE {p2} C2 {S} \<le> C \<longleftrightarrow>
  (\<exists>p1' p2' C1' C2' S'. C = IF b THEN {p1'} C1' ELSE {p2'} C2' {S'} \<and>
     p1 \<le> p1' \<and> p2 \<le> p2' \<and> C1 \<le> C1' \<and> C2 \<le> C2' \<and> S \<le> S')"
apply (cases C)
apply(auto simp: less_eq_acom_annos list_all2_append size_annos_same2)
done

lemma While_le[simp]: "{I} WHILE b DO {p} C {P} \<le> W \<longleftrightarrow>
  (\<exists>I' p' C' P'. W = {I'} WHILE b DO {p'} C' {P'} \<and> C \<le> C' \<and> p \<le> p' \<and> I \<le> I' \<and> P \<le> P')"
apply (cases W)
apply(auto simp: less_eq_acom_annos list_all2_append size_annos_same2)
done

lemma mono_post: "C \<le> C' \<Longrightarrow> post C \<le> post C'"
using annos_ne[of C']
by(auto simp: post_def less_eq_acom_def last_conv_nth[OF annos_ne] anno_def
     dest: size_annos_same)

definition Inf_acom :: "com \<Rightarrow> 'a::complete_lattice acom set \<Rightarrow> 'a acom" where
"Inf_acom c M = annotate (\<lambda>p. INF C\<in>M. anno C p) c"

global_interpretation
  Complete_Lattice "{C. strip C = c}" "Inf_acom c" for c
proof (standard, goal_cases)
  case 1 thus ?case
    by(auto simp: Inf_acom_def less_eq_acom_def size_annos intro:INF_lower)
next
  case 2 thus ?case
    by(auto simp: Inf_acom_def less_eq_acom_def size_annos intro:INF_greatest)
next
  case 3 thus ?case by(auto simp: Inf_acom_def)
qed

definition "step = Step (\<lambda>x e S. {s(x := aval e s) |s. s \<in> S}) (\<lambda>b S. {s:S. bval b s = Some True})"

definition CS :: "com \<Rightarrow> state set acom" where
"CS c = lfp c (step UNIV)"

lemma mono2_Step: fixes C1 C2 :: "'a::semilattice_sup acom"
  assumes "!!x e S1 S2. S1 \<le> S2 \<Longrightarrow> f x e S1 \<le> f x e S2"
          "!!b S1 S2. S1 \<le> S2 \<Longrightarrow> g b S1 \<le> g b S2"
  shows "C1 \<le> C2 \<Longrightarrow> S1 \<le> S2 \<Longrightarrow> Step f g S1 C1 \<le> Step f g S2 C2"
proof(induction S1 C1 arbitrary: C2 S2 rule: Step.induct)
  case 1 thus ?case by(auto)
next
  case 2 thus ?case by (auto simp: assms(1))
next
  case 3 thus ?case by(auto simp: mono_post)
next
  case 4 thus ?case
    by(auto simp: subset_iff assms(2))
      (metis mono_post le_supI1 le_supI2)+
next
  case 5 thus ?case
    by(auto simp: subset_iff assms(2))
      (metis mono_post le_supI1 le_supI2)+
qed

lemma mono2_step: "C1 \<le> C2 \<Longrightarrow> S1 \<subseteq> S2 \<Longrightarrow> step S1 C1 \<le> step S2 C2"
unfolding step_def by(rule mono2_Step) auto

lemma mono_step: "mono (step S)"
by(blast intro: monoI mono2_step)

lemma strip_step: "strip(step S C) = strip C"
by (induction C arbitrary: S) (auto simp: step_def)

lemma lfp_cs_unfold: "lfp c (step S) = step S (lfp c (step S))"
apply(rule lfp_unfold[OF _  mono_step])
apply(simp add: strip_step)
done

lemma CS_unfold: "CS c = step UNIV (CS c)"
by (metis CS_def lfp_cs_unfold)

lemma strip_CS[simp]: "strip(CS c) = c"
by(simp add: CS_def index_lfp[simplified])

lemma asize_nz: "asize(c::com) \<noteq> 0"
by (metis length_0_conv length_annos_annotate annos_ne)

lemma post_Inf_acom:
  "\<forall>C\<in>M. strip C = c \<Longrightarrow> post (Inf_acom c M) = \<Inter>(post ` M)"
apply(subgoal_tac "\<forall>C\<in>M. size(annos C) = asize c")
 apply(simp add: post_anno_asize Inf_acom_def asize_nz neq0_conv[symmetric])
apply(simp add: size_annos)
done

lemma post_lfp: "post(lfp c f) = (\<Inter>{post C|C. strip C = c \<and> f C \<le> C})"
by(auto simp add: lfp_def post_Inf_acom)

lemma big_step_post_step:
  "\<lbrakk> (c, s) \<Rightarrow> t;  strip C = c;  s \<in> S;  step S C \<le> C \<rbrakk> \<Longrightarrow> t \<in> post C"
proof(induction arbitrary: C S rule: big_step_induct)
  case Skip thus ?case by(auto simp: strip_eq_SKIP step_def post_def)
next
  case Assign thus ?case
    by(fastforce simp: strip_eq_Assign step_def post_def)
next
  case Seq thus ?case
    by(fastforce simp: strip_eq_Seq step_def post_def last_append annos_ne)
next
  case IfTrue thus ?case apply(auto simp: strip_eq_If step_def post_def)
    using subset_eq by blast
next
  case IfFalse thus ?case apply(auto simp: strip_eq_If step_def post_def)
    using subset_eq by blast
next
  case (WhileTrue b s1 c' s2 s3)
  from WhileTrue.prems(1) obtain I P C' Q where "C = {I} WHILE b DO {P} C' {Q}" "strip C' = c'"
    by(auto simp: strip_eq_While)
  from WhileTrue.prems(3) \<open>C = _\<close>
  have "step P C' \<le> C'"  "{s \<in> I. bval b s = Some True} \<le> P"  "S \<le> I"  "step (post C') C \<le> C"
    by (auto simp: step_def post_def)
  have "step {s \<in> I. bval b s = Some True} C' \<le> C'"
    by (rule order_trans[OF mono2_step[OF order_refl \<open>{s \<in> I. bval b s = Some True} \<le> P\<close>] \<open>step P C' \<le> C'\<close>])
  have "s1 \<in> {s\<in>I. bval b s = Some True}" using \<open>s1 \<in> S\<close> \<open>S \<subseteq> I\<close> \<open>bval b s1 = Some True\<close> by auto
  note s2_in_post_C' = WhileTrue.IH(1)[OF \<open>strip C' = c'\<close> this \<open>step {s \<in> I. bval b s = Some True} C' \<le> C'\<close>]
  from WhileTrue.IH(2)[OF WhileTrue.prems(1) s2_in_post_C' \<open>step (post C') C \<le> C\<close>]
  show ?case .
next
  case (WhileFalse b s1 c') thus ?case
    by (force simp: strip_eq_While step_def post_def)
qed

lemma big_step_lfp: "\<lbrakk> (c,s) \<Rightarrow> t;  s \<in> S \<rbrakk> \<Longrightarrow> t \<in> post(lfp c (step S))"
by(auto simp add: post_lfp intro: big_step_post_step)

lemma big_step_CS: "(c,s) \<Rightarrow> t \<Longrightarrow> t \<in> post(CS c)"
by(simp add: CS_def big_step_lfp)

datatype bound = NegInf ("\<infinity>\<^sup>-") | PosInf ("\<infinity>\<^sup>+") | NaN | Real
datatype bounds = B "bound set"

datatype parity = Even | Odd | Either
datatype entry = Unchanged ("'_'_'_'_'_'_'_'_") | None | Some parity

consts A\<^sub>0 :: "entry list"

consts A\<^sub>1 :: "entry list"

consts A\<^sub>2 :: "entry list"

consts A\<^sub>3 :: "entry list"

consts A\<^sub>4 :: "entry list"

consts A\<^sub>5 :: "entry list"

consts A\<^sub>6 :: "entry list"

consts A\<^sub>7 :: "entry list"

consts A\<^sub>8 :: "entry list"

consts A\<^sub>9 :: "entry list"

consts \<gamma>_bounds :: "bounds \<Rightarrow> val set"

consts num_bounds :: "ereal \<Rightarrow> bounds"

consts plus_bounds :: "bounds \<Rightarrow> bounds \<Rightarrow> bounds"

consts m_bounds :: "bounds \<Rightarrow> nat"

end


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

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

fun take :: "int => 'a list => 'a list" where
  "take x y =
   (if x <= 0 then nil2 else
      (case y of
         nil2 => nil2
         | cons2 z xs => cons2 z (take (x - 1) xs)))"

fun ordered :: "int list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 y (nil2)) = True"
| "ordered (cons2 y (cons2 y2 xs)) =
     ((y <= y2) & (ordered (cons2 y2 xs)))"

fun lmerge :: "int list => int list => int list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if z <= x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun length :: "'a list => int" where
  "length (nil2) = 0"
| "length (cons2 y l) = 1 + (length l)"

fun drop :: "int => 'a list => 'a list" where
  "drop x y =
   (if x <= 0 then y else
      (case y of
         nil2 => nil2
         | cons2 z xs1 => drop (x - 1) xs1))"

(*fun did not finish the proof*)
function msorttd :: "int list => int list" where
  "msorttd (nil2) = nil2"
| "msorttd (cons2 y (nil2)) = cons2 y (nil2)"
| "msorttd (cons2 y (cons2 x2 x3)) =
     (let k :: int = (op div) (length (cons2 y (cons2 x2 x3))) 2
     in lmerge
          (msorttd (take k (cons2 y (cons2 x2 x3))))
          (msorttd (drop k (cons2 y (cons2 x2 x3)))))"
  by pat_completeness auto

theorem property0 :
  "ordered (msorttd xs)"
  oops

end


theory NaDeA imports Main begin                                                                     (*  Isabelle theory file (Isabelle2022)                                       *)
                                                                                (*                                                                            *)
type_synonym id = "char list"                                                                       (*  A function/predicate identifier is a list of characters.                  *)
                                                                                (*                                                                            *)
datatype tm = Var nat | Fun id "tm list"                                                            (*  Variables are enumerated by natural numbers (de Bruijn indices).          *)
                                                                                (*                                                                            *)
datatype fm = Falsity | Pre id "tm list" | Imp fm fm | Dis fm fm | Con fm fm | Exi fm | Uni fm      (*  The formula classes. There is no negation or bi-implication.              *)
                                                                                (*                                                                            *)
primrec                                                                                (*                                                                            *)
  semantics_term :: "(nat => 'a) => (id => 'a list => 'a) => tm => 'a"                              (*  Semantics of terms are values in the universe. The type is arbitrary.     *)
and                                                                                (*                                                                            *)
  semantics_list :: "(nat => 'a) => (id => 'a list => 'a) => tm list => 'a list"                    (*  Semantics of lists (of terms) are lists of values in the universe.        *)
where                                                                                (*                                                                            *)
  "semantics_term e f (Var n) = e n" |                                                              (*  Values of variables are obtained by look up in the variable environment.  *)
  "semantics_term e f (Fun i l) = f i (semantics_list e f l)" |                                     (*  Functions are looked up in the function environment.                      *)
  "semantics_list e f [] = []" |                                                                    (*  List semantics: List of semantic values of terms.                         *)
  "semantics_list e f (t # l) = semantics_term e f t # semantics_list e f l"                        (*                                                                            *)
                                                                                (*                                                                            *)
primrec                                                                                (*                                                                            *)
  semantics :: "(nat => 'a) => (id => 'a list => 'a) => (id => 'a list => bool) => fm => bool"      (*  Semantics give truth values to formulas. Takes a variable environment,    *)
where                                                                                (*  a function environment, predicate environment, and a formula.             *)
  "semantics e f g Falsity = False" |                                                               (*                                                                            *)
  "semantics e f g (Pre i l) = g i (semantics_list e f l)" |                                        (*                                                                            *)
  "semantics e f g (Imp p q) = (if semantics e f g p then semantics e f g q else True)" |           (*                                                                            *)
  "semantics e f g (Dis p q) = (if semantics e f g p then True else semantics e f g q)" |           (*                                                                            *)
  "semantics e f g (Con p q) = (if semantics e f g p then semantics e f g q else False)" |          (*                                                                            *)
  "semantics e f g (Exi p) = (? x. semantics (% n. if n = 0 then x else e (n - 1)) f g p)" |        (*  ? is for existential quantification. % is for lambda abstraction.         *)
  "semantics e f g (Uni p) = (! x. semantics (% n. if n = 0 then x else e (n - 1)) f g p)"          (*  ! is for universal quantification.                                        *)
                                                                                (*                                                                            *)
primrec                                                                                (*                                                                            *)
  member :: "fm => fm list => bool"                                                                 (*  member: Determines if a formula is contained in a list of formulas.       *)
where                                                                                (*                                                                            *)
  "member p [] = False" |                                                                           (*                                                                            *)
  "member p (q # z) = (if p = q then True else member p z)"                                         (*                                                                            *)
                                                                                (*                                                                            *)
primrec                                                                                (*                                                                            *)
  new_term :: "id => tm => bool"                                                                    (*  new_term: Determines if the identifier is new in the term.                *)
and                                                                                (*                                                                            *)
  new_list :: "id => tm list => bool"                                                               (*  new_list: Determines if the identifier is new in the list of terms.       *)
where                                                                                (*                                                                            *)
  "new_term c (Var n) = True" |                                                                     (*                                                                            *)
  "new_term c (Fun i l) = (if i = c then False else new_list c l)" |                                (*                                                                            *)
  "new_list c [] = True" |                                                                          (*                                                                            *)
  "new_list c (t # l) = (if new_term c t then new_list c l else False)"                             (*                                                                            *)
                                                                                (*                                                                            *)
primrec                                                                                (*                                                                            *)
  new :: "id => fm => bool"                                                                         (*  new: Determines if the identifier is new in the formula.                  *)
where                                                                                (*                                                                            *)
  "new c Falsity = True" |                                                                          (*                                                                            *)
  "new c (Pre i l) = new_list c l" |                                                                (*                                                                            *)
  "new c (Imp p q) = (if new c p then new c q else False)" |                                        (*                                                                            *)
  "new c (Dis p q) = (if new c p then new c q else False)" |                                        (*                                                                            *)
  "new c (Con p q) = (if new c p then new c q else False)" |                                        (*                                                                            *)
  "new c (Exi p) = new c p" |                                                                       (*                                                                            *)
  "new c (Uni p) = new c p"                                                                         (*                                                                            *)
                                                                                (*                                                                            *)
primrec                                                                                (*                                                                            *)
  news :: "id => fm list => bool"                                                                   (*  news: Determines if the identifier is new the list of formulas.           *)
where                                                                                (*                                                                            *)
  "news c [] = True" |                                                                              (*                                                                            *)
  "news c (p # z) = (if new c p then news c z else False)"                                          (*                                                                            *)
                                                                                (*                                                                            *)
primrec                                                                                (*                                                                            *)
  inc_term :: "tm => tm"                                                                            (*                                                                            *)
and                                                                                (*                                                                            *)
  inc_list :: "tm list => tm list"                                                                  (*                                                                            *)
where                                                                                (*                                                                            *)
  "inc_term (Var n) = Var (n + 1)" |                                                                (*                                                                            *)
  "inc_term (Fun i l) = Fun i (inc_list l)" |                                                       (*                                                                            *)
  "inc_list [] = []" |                                                                              (*                                                                            *)
  "inc_list (t # l) = inc_term t # inc_list l"                                                      (*                                                                            *)
                                                                                (*                                                                            *)
primrec                                                                                (*                                                                            *)
  sub_term :: "nat => tm => tm => tm"                                                               (*  sub_term: Substitutes a variable in the term with a given term.           *)
and                                                                                (*                                                                            *)
  sub_list :: "nat => tm => tm list => tm list"                                                     (*  sub_list: Substitutes a variable in the term list with a given term.      *)
where                                                                                (*                                                                            *)
  "sub_term v s (Var n) = (if n < v then Var n else if n = v then s else Var (n - 1))" |            (*                                                                            *)
  "sub_term v s (Fun i l) = Fun i (sub_list v s l)" |                                               (*                                                                            *)
  "sub_list v s [] = []" |                                                                          (*                                                                            *)
  "sub_list v s (t # l) = sub_term v s t # sub_list v s l"                                          (*                                                                            *)
                                                                                (*                                                                            *)
primrec                                                                                (*                                                                            *)
  sub :: "nat => tm => fm => fm"                                                                    (*  sub: Substitutes a variable in the formula with a given term.             *)
where                                                                                (*                                                                            *)
  "sub v s Falsity = Falsity" |                                                                     (*                                                                            *)
  "sub v s (Pre i l) = Pre i (sub_list v s l)" |                                                    (*                                                                            *)
  "sub v s (Imp p q) = Imp (sub v s p) (sub v s q)" |                                               (*                                                                            *)
  "sub v s (Dis p q) = Dis (sub v s p) (sub v s q)" |                                               (*                                                                            *)
  "sub v s (Con p q) = Con (sub v s p) (sub v s q)" |                                               (*                                                                            *)
  "sub v s (Exi p) = Exi (sub (v + 1) (inc_term s) p)" |                                            (*                                                                            *)
  "sub v s (Uni p) = Uni (sub (v + 1) (inc_term s) p)"                                              (*                                                                            *)
                                                                                (*                                                                            *)
inductive                                                                                (*                                                                            *)
  OK :: "fm => fm list => bool"                                                                     (*  OK: Inductive definition of proof rules.                                  *)
where                                                                                (*                                                                            *)
Assume:                                                                                (*                                                                            *)
        "member p z ==> OK p z" |                                                                   (*                                                                            *)
Boole:                                                                                (*                                                                            *)
        "OK Falsity ((Imp p Falsity) # z) ==> OK p z" |                                             (*                                                                            *)
Imp_E:                                                                                (*                                                                            *)
        "OK (Imp p q) z ==> OK p z ==> OK q z" |                                                    (*                                                                            *)
Imp_I:                                                                                (*                                                                            *)
        "OK q (p # z) ==> OK (Imp p q) z" |                                                         (*                                                                            *)
Dis_E:                                                                                (*                                                                            *)
        "OK (Dis p q) z ==> OK r (p # z) ==> OK r (q # z) ==> OK r z" |                             (*                                                                            *)
Dis_I1:                                                                                (*                                                                            *)
        "OK p z ==> OK (Dis p q) z" |                                                               (*                                                                            *)
Dis_I2:                                                                                (*                                                                            *)
        "OK q z ==> OK (Dis p q) z" |                                                               (*                                                                            *)
Con_E1:                                                                                (*                                                                            *)
        "OK (Con p q) z ==> OK p z" |                                                               (*                                                                            *)
Con_E2:                                                                                (*                                                                            *)
        "OK (Con p q) z ==> OK q z" |                                                               (*                                                                            *)
Con_I:                                                                                (*                                                                            *)
        "OK p z ==> OK q z ==> OK (Con p q) z" |                                                    (*                                                                            *)
Exi_E:                                                                                (*                                                                            *)
        "OK (Exi p) z ==> OK q ((sub 0 (Fun c []) p) # z) ==> news c (p # q # z) ==> OK q z" |      (*  "sub 0 (Fun c []) p" substitutes variables with de Bruijn index 0         *)
Exi_I:                                                                                (*  for a new (fresh) constant c. Newness ensured by "news" statement.        *)
        "OK (sub 0 t p) z ==> OK (Exi p) z" |                                                       (*                                                                            *)
Uni_E:                                                                                (*                                                                            *)
        "OK (Uni p) z ==> OK (sub 0 t p) z" |                                                       (*                                                                            *)
Uni_I:                                                                                (*                                                                            *)
        "OK (sub 0 (Fun c []) p) z ==> news c (p # z) ==> OK (Uni p) z"                             (*                                                                            *)
                                                                                (*                                                                            *)
lemma "OK (Imp (Pre ''A'' []) (Pre ''A'' [])) []" proof (rule Imp_I, rule Assume, simp) qed         (*  Formula "A --> A" example but not declarative style...                    *)
                                                                                (*                                                                            *)
lemma "OK (Imp (Pre ''A'' []) (Pre ''A'' [])) []"                                                   (*  Formula "A --> A" example.                                                *)
proof -                                                                                (*  Note "-" to start from nothing.                                           *)
  have "OK (Pre ''A'' []) [(Pre ''A'' [])]" proof (rule Assume) qed simp                            (*                                                                            *)
  then show "OK (Imp (Pre ''A'' []) (Pre ''A'' [])) []" proof (rule Imp_I) qed                      (*                                                                            *)
qed                                                                                (*                                                                            *)
                                                                                (*                                                                            *)
fun                                                                                (*                                                                            *)
  put :: "(nat => 'a) => nat => 'a => nat => 'a"                                                    (*  put: Inserts a value in the environment at a given index.                 *)
where                                                                                (*       Existing values with equal/higher index are shifted to the right.    *)
  "put e v x = (% n. if n < v then e n else if n = v then x else e (n - 1))"                        (*                                                                            *)
                                                                                (*                                                                            *)
lemma "put e 0 x = (% n. if n = 0 then x else e (n - 1))" proof simp qed                            (*  Lemma: Applying "put" to index 0 removes the need for else-if construct.  *)
                                                                                (*                                                                            *)
lemma increment:                                                                                (*                                                                            *)
  "semantics_term (put e 0 x) f (inc_term t) = semantics_term e f t"                                (*  The semantic of a term (or list) is unchanged if we put a new variable    *)
  "semantics_list (put e 0 x) f (inc_list l) = semantics_list e f l"                                (*  value into the environment at index 0 and increment the variables         *)
proof (induct t and l rule: semantics_term.induct semantics_list.induct) qed simp_all               (*  occurring inside the term.                                                *)
                                                                                (*                                                                            *)
lemma commute: "put (put e v x) 0 y = put (put e 0 y) (v + 1) x" proof force qed                    (*  Lemma: The order of nested "put" commutes as long as you use              *)
                                                                                (*         the correct indexation.                                            *)
fun                                                                                (*                                                                            *)
  all :: "(fm => bool) => fm list => bool"                                                          (*  all: Checks if "b p" holds for all formulas p in the list.                *)
where                                                                                (*                                                                            *)
  "all b z = (! p. if member p z then b p else True)"                                               (*                                                                            *)
                                                                                (*                                                                            *)
lemma allhead: "all b (p # z) ==> b p" proof simp qed                                               (*  "all" holds for head of list.                                             *)
                                                                                (*                                                                            *)
lemma alltail: "all b (p # z) ==> all b z" proof simp qed                                           (*  "all" holds for tail of list.                                             *)
                                                                                (*                                                                            *)
lemma allnew: "all (new c) z = news c z" proof (induct z) qed (simp, simp, metis)                   (*  "all new" corresponds to "news".                                          *)
                                                                                (*                                                                            *)
lemma map':                                                                                (*  map': Mapping c to a different value does not change the                  *)
  "new_term c t ==> semantics_term e (f(c := m)) t = semantics_term e f t"                          (*        semantic value of the term/list that it is new in.                  *)
  "new_list c l ==> semantics_list e (f(c := m)) l = semantics_list e f l"                          (*                                                                            *)
proof (induct t and l rule: semantics_term.induct semantics_list.induct)                            (*                                                                            *)
qed (simp, simp, metis, simp, simp, metis)                                                          (*                                                                            *)
                                                                                (*                                                                            *)
lemma map: "new c p ==> semantics e (f(c := m)) g p = semantics e f g p"                            (*  map: The property of "map'" for terms/lists also holds for a formula,     *)
proof (induct p arbitrary: e)                                                                       (*       when the value c is new in the formula.                              *)
qed (simp, simp, metis map'(2), simp, metis, simp, metis, simp, metis, simp_all)                    (*                                                                            *)
                                                                                (*                                                                            *)
lemma allmap: "news c z ==> all (semantics e (f(c := m)) g) z = all (semantics e f g) z"            (*  allmap: "map" extended to list of formulas.                               *)
proof (induct z) qed (simp, simp, metis map)                                                        (*                                                                            *)
                                                                                (*                                                                            *)
lemma substitute':                                                                                (*                                                                            *)
  "semantics_term e f (sub_term v s t) = semantics_term (put e v (semantics_term e f s)) f t"       (*  substitute': Substituting a variable in a term/list corresponds           *)
  "semantics_list e f (sub_list v s l) = semantics_list (put e v (semantics_term e f s)) f l"       (*               semantically to updating the value of the variable           *)
proof (induct t and l rule: semantics_term.induct semantics_list.induct) qed simp_all               (*               in the environment.                                          *)
                                                                                (*                                                                            *)
lemma substitute: "semantics e f g (sub v t p) = semantics (put e v (semantics_term e f t)) f g p"  (*  substitute: "substitute'" generalized to hold for formulas.               *)
proof (induct p arbitrary: e v t)                                                                   (*                                                                            *)
  fix i l e v t                                                                                (*                                                                            *)
  show "semantics e f g (sub v t (Pre i l)) = semantics (put e v (semantics_term e f t)) f g (Pre i l)" (*                                                                        *)
  proof (simp add: substitute'(2)) qed                                                              (*                                                                            *)
next                                                                                (*  Holds for formulas within scope of existential quantification.            *)
  fix p e v t assume *: "semantics e' f g (sub v' t' p) = semantics (put e' v' (semantics_term e' f t')) f g p" for e' v' t' (*                                                   *)
  have "semantics e f g (sub v t (Exi p)) = (? x. semantics (put (put e 0 x) (v + 1) (semantics_term (put e 0 x) f (inc_term t))) f g p)" (*                                      *)
    using * proof simp qed                                                                          (*  Substitution within "Exi" can be obtained through "put" and "inc_term".   *)
  also have "... = (? x. semantics (put (put e v (semantics_term e f t)) 0 x) f g p)"               (*                                                                            *)
    using commute increment(1) proof metis qed                                                      (*  Using lemmas "commute" and "increment", we can reduce it to only "put".   *)
  finally show "semantics e f g (sub v t (Exi p)) = semantics (put e v (semantics_term e f t)) f g (Exi p)" proof simp qed (*                                                     *)
  have "semantics e f g (sub v t (Uni p)) = (! x. semantics (put (put e 0 x) (v + 1) (semantics_term (put e 0 x) f (inc_term t))) f g p)" (*                                      *)
    using * proof simp qed                                                                          (*  Holds for universal quantification. Same as for Exi p.                    *)
  also have "... = (! x. semantics (put (put e v (semantics_term e f t)) 0 x) f g p)"               (*                                                                            *)
    using commute increment(1) proof metis qed                                                      (*                                                                            *)
  finally show "semantics e f g (sub v t (Uni p)) = semantics (put e v (semantics_term e f t)) f g (Uni p)" proof simp qed (*                                                     *)
qed simp_all                                                                                (*  The remaining cases are proved by simplification.                         *)
                                                                                (*                                                                            *)
lemma soundness': "OK p z ==> all (semantics e f g) z ==> semantics e f g p"                        (*  soundness': Proof rules are sound for arbitrary lists of assumptions.     *)
proof (induct arbitrary: f rule: OK.induct)                                                         (*  Proof by induction.                                                       *)
  fix f p z assume "all (semantics e f g) z"                                                        (*  Case: Boole.                                                              *)
      "all (semantics e f' g) (Imp p Falsity # z) ==> semantics e f' g Falsity" for f'              (*                                                                            *)
  then show "semantics e f g p" proof force qed                                                     (*                                                                            *)
next                                                                                (*                                                                            *)
  fix f p q z r assume "all (semantics e f g) z"                                                    (*  Case: Disjunction Elimination.                                            *)
      "all (semantics e f' g) z ==> semantics e f' g (Dis p q)"                                     (*                                                                            *)
      "all (semantics e f' g) (p # z) ==> semantics e f' g r"                                       (*                                                                            *)
      "all (semantics e f' g) (q # z) ==> semantics e f' g r" for f'                                (*                                                                            *)
  then show "semantics e f g r" proof (simp, metis) qed                                             (*                                                                            *)
next                                                                                (*                                                                            *)
  fix f p q z assume "all (semantics e f g) z"                                                      (*  Case: Conjunction Elimination.                                            *)
      "all (semantics e f' g) z ==> semantics e f' g (Con p q)" for f'                              (*                                                                            *)
  then show "semantics e f g p" "semantics e f g q" proof (simp, metis, simp, metis) qed            (*                                                                            *)
next                                                                                (*                                                                            *)
  fix f p z q c assume *: "all (semantics e f g) z"                                                 (*  Case: Existential Elimination.                                            *)
      "all (semantics e f' g) z ==> semantics e f' g (Exi p)"                                       (*                                                                            *)
      "all (semantics e f' g) (sub 0 (Fun c []) p # z) ==> semantics e f' g q"                      (*                                                                            *)
      "news c (p # q # z)" for f'                                                                   (*                                                                            *)
  obtain x where "semantics (% n. if n = 0 then x else e (n - 1)) f g p"                            (*                                                                            *)
    using *(1) *(2) proof force qed                                                                 (*                                                                            *)
  then have "semantics (put e 0 x) f g p" proof simp qed                                            (*                                                                            *)
  then have "semantics (put e 0 x) (f(c := % w. x)) g p"                                            (*                                                                            *)
    using *(4) allhead allnew map proof blast qed                                                   (*                                                                            *)
  then have "semantics e (f(c := % w. x)) g (sub 0 (Fun c []) p)"                                   (*                                                                            *)
    proof (simp add: substitute) qed                                                                (*                                                                            *)
  moreover have "all (semantics e (f(c := % w. x)) g) z"                                            (*                                                                            *)
    using *(1) *(4) alltail allnew allmap proof blast qed                                           (*                                                                            *)
  ultimately have "semantics e (f(c := % w. x)) g q" using *(3) proof simp qed                      (*                                                                            *)
  then show "semantics e f g q" using *(4) allhead alltail allnew map proof blast qed               (*                                                                            *)
next                                                                                (*                                                                            *)
  fix f z t p assume "all (semantics e f g) z"                                                      (*  Case: Existential Introduction.                                           *)
      "all (semantics e f' g) z ==> semantics e f' g (sub 0 t p)" for f'                            (*                                                                            *)
  then have "semantics (put e 0 (semantics_term e f t)) f g p" proof (simp add: substitute) qed     (*                                                                            *)
  then show "semantics e f g (Exi p)" proof (simp, metis) qed                                       (*                                                                            *)
next                                                                                (*                                                                            *)
  fix f z t p assume "all (semantics e f g) z"                                                      (*  Case: Universal Elimination.                                              *)
      "all (semantics e f' g) z ==> semantics e f' g (Uni p)" for f'                                (*                                                                            *)
  then show "semantics e f g (sub 0 t p)" proof (simp add: substitute) qed                          (*                                                                            *)
next                                                                                (*                                                                            *)
  fix f c p z assume *: "all (semantics e f g) z"                                                   (*  Case: Universal Introduction.                                             *)
      "all (semantics e f' g) z ==> semantics e f' g (sub 0 (Fun c []) p)"                          (*                                                                            *)
      "news c (p # z)" for f'                                                                       (*                                                                            *)
  have "semantics (% n. if n = 0 then x else e (n - 1)) f g p" for x                                (*                                                                            *)
  proof -                                                                                (*                                                                            *)
    have "all (semantics e (f(c := % w. x)) g) z"                                                   (*                                                                            *)
      using *(1) *(3) alltail allnew allmap proof blast qed                                         (*                                                                            *)
    then have "semantics e (f(c := % w. x)) g (sub 0 (Fun c []) p)"                                 (*                                                                            *)
      using *(2) proof simp qed                                                                     (*                                                                            *)
    then have "semantics (% n. if n = 0 then x else e (n - 1)) (f(c := % w. x)) g p"                (*                                                                            *)
      proof (simp add: substitute) qed                                                              (*                                                                            *)
    then show "semantics (% n. if n = 0 then x else e (n - 1)) f g p"                               (*                                                                            *)
      using *(3) allhead alltail allnew map proof blast qed                                         (*                                                                            *)
  qed                                                                                (*                                                                            *)
  then show "semantics e f g (Uni p)" proof simp qed                                                (*                                                                            *)
qed simp_all                                                                                (*  The remaining cases are proved by simplification.                         *)
                                                                                (*                                                                            *)
theorem soundness: "OK p [] ==> semantics e f g p" proof (simp add: soundness') qed                 (*  soundness: Proof rules are sound starting from no assumptions.            *)
                                                                                (*             This is directly derived once soundness' is proved.            *)
corollary "? p. OK p []" "? p. ~ OK p []"                                                           (*                                                                            *)
proof -                                                                                (*  Proof of consistency: Something, but not everything, can be proved.       *)
  have "OK (Imp p p) []" for p proof (rule Imp_I, rule Assume, simp) qed                            (*                                                                            *)
  then show "? p. OK p []" proof iprover qed                                                        (*                                                                            *)
next                                                                                (*                                                                            *)
  have "~ semantics (e :: nat => unit) f g Falsity" for e f g proof simp qed                        (*                                                                            *)
  then show "? p. ~ OK p []" using soundness proof iprover qed                                      (*                                                                            *)
qed                                                                                (*                                                                            *)
                                                                                (*                                                                            *)
end                                                                                (*                                                                            *)