(*  Title:      HOL/SPARK/Examples/Liseq/Longest_Increasing_Subsequence.thy
    Author:     Stefan Berghofer
    Copyright:  secunet Security Networks AG
*)

theory Longest_Increasing_Subsequence
imports "../../SPARK"
begin

text {*
Set of all increasing subsequences in a prefix of an array
*}

definition iseq :: "(nat \<Rightarrow> 'a::linorder) \<Rightarrow> nat \<Rightarrow> nat set set" where
  "iseq xs l = {is. (\<forall>i\<in>is. i < l) \<and>
     (\<forall>i\<in>is. \<forall>j\<in>is. i \<le> j \<longrightarrow> xs i \<le> xs j)}"

text {*
Length of longest increasing subsequence in a prefix of an array
*}

definition liseq :: "(nat \<Rightarrow> 'a::linorder) \<Rightarrow> nat \<Rightarrow> nat" where
  "liseq xs i = Max (card ` iseq xs i)"

text {*
Length of longest increasing subsequence ending at a particular position
*}

definition liseq' :: "(nat \<Rightarrow> 'a::linorder) \<Rightarrow> nat \<Rightarrow> nat" where
  "liseq' xs i = Max (card ` (iseq xs (Suc i) \<inter> {is. Max is = i}))"

lemma iseq_finite: "finite (iseq xs i)"
  apply (simp add: iseq_def)
  apply (rule finite_subset [OF _
    finite_Collect_subsets [of "{j. j < i}"]])
  apply auto
  done

lemma iseq_finite': "is \<in> iseq xs i \<Longrightarrow> finite is"
  by (auto simp add: iseq_def bounded_nat_set_is_finite)

lemma iseq_singleton: "i < l \<Longrightarrow> {i} \<in> iseq xs l"
  by (simp add: iseq_def)

lemma iseq_trivial: "{} \<in> iseq xs i"
  by (simp add: iseq_def)

lemma iseq_nonempty: "iseq xs i \<noteq> {}"
  by (auto intro: iseq_trivial)

lemma liseq'_ge1: "1 \<le> liseq' xs x"
  apply (simp add: liseq'_def)
  apply (subgoal_tac "iseq xs (Suc x) \<inter> {is. Max is = x} \<noteq> {}")
  apply (simp add: Max_ge_iff iseq_finite)
  apply (rule_tac x="{x}" in bexI)
  apply (auto intro: iseq_singleton)
  done

lemma liseq_expand:
  assumes R: "\<And>is. liseq xs i = card is \<Longrightarrow> is \<in> iseq xs i \<Longrightarrow>
    (\<And>js. js \<in> iseq xs i \<Longrightarrow> card js \<le> card is) \<Longrightarrow> P"
  shows "P"
proof -
  have "Max (card ` iseq xs i) \<in> card ` iseq xs i"
    by (rule Max_in) (simp_all add: iseq_finite iseq_nonempty)
  then obtain js where js: "liseq xs i = card js" and "js \<in> iseq xs i"
    by (rule imageE) (simp add: liseq_def)
  moreover {
    fix js'
    assume "js' \<in> iseq xs i"
    then have "card js' \<le> card js"
      by (simp add: js [symmetric] liseq_def iseq_finite iseq_trivial)
  }
  ultimately show ?thesis by (rule R)
qed

lemma liseq'_expand:
  assumes R: "\<And>is. liseq' xs i = card is \<Longrightarrow> is \<in> iseq xs (Suc i) \<Longrightarrow>
    finite is \<Longrightarrow> Max is = i \<Longrightarrow>
    (\<And>js. js \<in> iseq xs (Suc i) \<Longrightarrow> Max js = i \<Longrightarrow> card js \<le> card is) \<Longrightarrow>
    is \<noteq> {} \<Longrightarrow> P"
  shows "P"
proof -
  have "Max (card ` (iseq xs (Suc i) \<inter> {is. Max is = i})) \<in>
    card ` (iseq xs (Suc i) \<inter> {is. Max is = i})"
    by (auto simp add: iseq_finite intro!: iseq_singleton Max_in)
  then obtain js where js: "liseq' xs i = card js" and "js \<in> iseq xs (Suc i)"
    and "finite js" and "Max js = i"
    by (auto simp add: liseq'_def intro: iseq_finite')
  moreover {
    fix js'
    assume "js' \<in> iseq xs (Suc i)" "Max js' = i"
    then have "card js' \<le> card js"
      by (auto simp add: js [symmetric] liseq'_def iseq_finite intro!: iseq_singleton)
  }
  note max = this
  moreover have "card {i} \<le> card js"
    by (rule max) (simp_all add: iseq_singleton)
  then have "js \<noteq> {}" by auto
  ultimately show ?thesis by (rule R)
qed

lemma liseq'_ge:
  "j = card js \<Longrightarrow> js \<in> iseq xs (Suc i) \<Longrightarrow> Max js = i \<Longrightarrow>
  js \<noteq> {} \<Longrightarrow> j \<le> liseq' xs i"
  by (simp add: liseq'_def iseq_finite)

lemma liseq'_eq:
  "j = card js \<Longrightarrow> js \<in> iseq xs (Suc i) \<Longrightarrow> Max js = i \<Longrightarrow>
  js \<noteq> {} \<Longrightarrow> (\<And>js'. js' \<in> iseq xs (Suc i) \<Longrightarrow> Max js' = i \<Longrightarrow> finite js' \<Longrightarrow>
    js' \<noteq> {} \<Longrightarrow> card js' \<le> card js) \<Longrightarrow>
  j = liseq' xs i"
  by (fastforce simp add: liseq'_def iseq_finite
    intro: Max_eqI [symmetric])

lemma liseq_ge:
  "j = card js \<Longrightarrow> js \<in> iseq xs i \<Longrightarrow> j \<le> liseq xs i"
  by (auto simp add: liseq_def iseq_finite)

lemma liseq_eq:
  "j = card js \<Longrightarrow> js \<in> iseq xs i \<Longrightarrow>
  (\<And>js'. js' \<in> iseq xs i \<Longrightarrow> finite js' \<Longrightarrow>
    js' \<noteq> {} \<Longrightarrow> card js' \<le> card js) \<Longrightarrow>
  j = liseq xs i"
  by (fastforce simp add: liseq_def iseq_finite
    intro: Max_eqI [symmetric])

lemma max_notin: "finite xs \<Longrightarrow> Max xs < x \<Longrightarrow> x \<notin> xs"
  by (cases "xs = {}") auto

lemma iseq_insert:
  "xs (Max is) \<le> xs i \<Longrightarrow> is \<in> iseq xs i \<Longrightarrow>
  is \<union> {i} \<in> iseq xs (Suc i)"
  apply (frule iseq_finite')
  apply (cases "is = {}")
  apply (auto simp add: iseq_def)
  apply (rule order_trans [of _ "xs (Max is)"])
  apply auto
  apply (thin_tac "\<forall>a\<in>is. a < i")
  apply (drule_tac x=ia in bspec)
  apply assumption
  apply (drule_tac x="Max is" in bspec)
  apply (auto intro: Max_in)
  done

lemma iseq_diff: "is \<in> iseq xs (Suc (Max is)) \<Longrightarrow>
  is - {Max is} \<in> iseq xs (Suc (Max (is - {Max is})))"
  apply (frule iseq_finite')
  apply (simp add: iseq_def less_Suc_eq_le)
  done

lemma iseq_butlast:
  assumes "js \<in> iseq xs (Suc i)" and "js \<noteq> {}"
  and "Max js \<noteq> i"
  shows "js \<in> iseq xs i"
proof -
  from assms have fin: "finite js"
    by (simp add: iseq_finite')
  with assms have "Max js \<in> js"
    by auto
  with assms have "Max js < i"
    by (auto simp add: iseq_def)
  with fin assms have "\<forall>j\<in>js. j < i"
    by simp
  with assms show ?thesis
    by (simp add: iseq_def)
qed

lemma iseq_mono: "is \<in> iseq xs i \<Longrightarrow> i \<le> j \<Longrightarrow> is \<in> iseq xs j"
  by (auto simp add: iseq_def)

lemma diff_nonempty:
  assumes "1 < card is"
  shows "is - {i} \<noteq> {}"
proof -
  from assms have fin: "finite is" by (auto intro: card_ge_0_finite)
  with assms fin have "card is - 1 \<le> card (is - {i})"
    by (simp add: card_Diff_singleton_if)
  with assms have "0 < card (is - {i})" by simp
  then show ?thesis by (simp add: card_gt_0_iff)
qed

lemma Max_diff:
  assumes "1 < card is"
  shows "Max (is - {Max is}) < Max is"
proof -
  from assms have "finite is" by (auto intro: card_ge_0_finite)
  moreover from assms have "is - {Max is} \<noteq> {}"
    by (rule diff_nonempty)
  ultimately show ?thesis using assms
    apply (auto simp add: not_less)
    apply (subgoal_tac "a \<le> Max is")
    apply auto
    done
qed

lemma iseq_nth: "js \<in> iseq xs l \<Longrightarrow> 1 < card js \<Longrightarrow>
  xs (Max (js - {Max js})) \<le> xs (Max js)"
  apply (auto simp add: iseq_def)
  apply (subgoal_tac "Max (js - {Max js}) \<in> js")
  apply (thin_tac "\<forall>i\<in>js. i < l")
  apply (drule_tac x="Max (js - {Max js})" in bspec)
  apply assumption
  apply (drule_tac x="Max js" in bspec)
  using card_gt_0_iff [of js]
  apply simp
  using Max_diff [of js]
  apply simp
  using Max_in [of "js - {Max js}", OF _ diff_nonempty] card_gt_0_iff [of js]
  apply auto
  done

lemma card_leq1_singleton:
  assumes "finite xs" "xs \<noteq> {}" "card xs \<le> 1"
  obtains x where "xs = {x}"
  using assms
  by induct simp_all

lemma longest_iseq1:
  "liseq' xs i =
   Max ({0} \<union> {liseq' xs j |j. j < i \<and> xs j \<le> xs i}) + 1"
proof -
  have "Max ({0} \<union> {liseq' xs j |j. j < i \<and> xs j \<le> xs i}) = liseq' xs i - 1"
  proof (rule Max_eqI)
    fix y
    assume "y \<in> {0} \<union> {liseq' xs j |j. j < i \<and> xs j \<le> xs i}"
    then show "y \<le> liseq' xs i - 1"
    proof
      assume "y \<in> {liseq' xs j |j. j < i \<and> xs j \<le> xs i}"
      then obtain j where j: "j < i" "xs j \<le> xs i" "y = liseq' xs j"
        by auto
      have "liseq' xs j + 1 \<le> liseq' xs i"
      proof (rule liseq'_expand)
        fix "is"
        assume H: "liseq' xs j = card is" "is \<in> iseq xs (Suc j)"
          "finite is" "Max is = j" "is \<noteq> {}"
        from H j have "card is + 1 = card (is \<union> {i})"
          by (simp add: card_insert max_notin)
        moreover {
          from H j have "xs (Max is) \<le> xs i" by simp
          moreover from `j < i` have "Suc j \<le> i" by simp
          with `is \<in> iseq xs (Suc j)` have "is \<in> iseq xs i"
            by (rule iseq_mono)
          ultimately have "is \<union> {i} \<in> iseq xs (Suc i)"
          by (rule iseq_insert)
        } moreover from H j have "Max (is \<union> {i}) = i" by simp
        moreover have "is \<union> {i} \<noteq> {}" by simp
        ultimately have "card is + 1 \<le> liseq' xs i"
          by (rule liseq'_ge)
        with H show ?thesis by simp
      qed
      with j show "y \<le> liseq' xs i - 1"
        by simp
    qed simp
  next
    have "liseq' xs i \<le> 1 \<or>
      (\<exists>j. liseq' xs i - 1 = liseq' xs j \<and> j < i \<and> xs j \<le> xs i)"
    proof (rule liseq'_expand)
      fix "is"
      assume H: "liseq' xs i = card is" "is \<in> iseq xs (Suc i)"
        "finite is" "Max is = i" "is \<noteq> {}"
      assume R: "\<And>js. js \<in> iseq xs (Suc i) \<Longrightarrow> Max js = i \<Longrightarrow>
        card js \<le> card is"
      show ?thesis
      proof (cases "card is \<le> 1")
        case True with H show ?thesis by simp
      next
        case False
        then have "1 < card is" by simp
        then have "Max (is - {Max is}) < Max is"
          by (rule Max_diff)
        from `is \<in> iseq xs (Suc i)` `1 < card is`
        have "xs (Max (is - {Max is})) \<le> xs (Max is)"
          by (rule iseq_nth)
        have "card is - 1 = liseq' xs (Max (is - {i}))"
        proof (rule liseq'_eq)
          from `Max is = i` [symmetric] `finite is` `is \<noteq> {}`
          show "card is - 1 = card (is - {i})" by simp
        next
          from `is \<in> iseq xs (Suc i)` `Max is = i` [symmetric]
          show "is - {i} \<in> iseq xs (Suc (Max (is - {i})))"
            by simp (rule iseq_diff)
        next
          from `1 < card is`
          show "is - {i} \<noteq> {}" by (rule diff_nonempty)
        next
          fix js
          assume "js \<in> iseq xs (Suc (Max (is - {i})))"
            "Max js = Max (is - {i})" "finite js" "js \<noteq> {}"
          from `xs (Max (is - {Max is})) \<le> xs (Max is)`
            `Max js = Max (is - {i})` `Max is = i`
          have "xs (Max js) \<le> xs i" by simp
          moreover from `Max is = i` `Max (is - {Max is}) < Max is`
          have "Suc (Max (is - {i})) \<le> i"
            by simp
          with `js \<in> iseq xs (Suc (Max (is - {i})))`
          have "js \<in> iseq xs i"
            by (rule iseq_mono)
          ultimately have "js \<union> {i} \<in> iseq xs (Suc i)"
            by (rule iseq_insert)
          moreover from `js \<noteq> {}` `finite js` `Max js = Max (is - {i})`
            `Max is = i` [symmetric] `Max (is - {Max is}) < Max is`
          have "Max (js \<union> {i}) = i"
            by simp
          ultimately have "card (js \<union> {i}) \<le> card is" by (rule R)
          moreover from `Max is = i` [symmetric] `finite js`
            `Max (is - {Max is}) < Max is` `Max js = Max (is - {i})`
          have "i \<notin> js" by (simp add: max_notin)
          with `finite js`
          have "card (js \<union> {i}) = card ((js \<union> {i}) - {i}) + 1"
            by simp
          ultimately show "card js \<le> card (is - {i})"
            using `i \<notin> js` `Max is = i` [symmetric] `is \<noteq> {}` `finite is`
            by simp
        qed simp
        with H `Max (is - {Max is}) < Max is`
          `xs (Max (is - {Max is})) \<le> xs (Max is)`
        show ?thesis by auto
      qed
    qed
    then show "liseq' xs i - 1 \<in> {0} \<union>
      {liseq' xs j |j. j < i \<and> xs j \<le> xs i}" by simp
  qed simp
  moreover have "1 \<le> liseq' xs i" by (rule liseq'_ge1)
  ultimately show ?thesis by simp
qed

lemma longest_iseq2': "liseq xs i < liseq' xs i \<Longrightarrow>
  liseq xs (Suc i) = liseq' xs i"
  apply (rule_tac xs=xs and i=i in liseq'_expand)
  apply simp
  apply (rule liseq_eq [symmetric])
  apply (rule refl)
  apply assumption
  apply (case_tac "Max js' = i")
  apply simp
  apply (drule_tac js=js' in iseq_butlast)
  apply assumption+
  apply (drule_tac js=js' in liseq_ge [OF refl])
  apply simp
  done

lemma longest_iseq2: "liseq xs i < liseq' xs i \<Longrightarrow>
  liseq xs i + 1 = liseq' xs i"
  apply (rule_tac xs=xs and i=i in liseq'_expand)
  apply simp
  apply (rule_tac xs=xs and i=i in liseq_expand)
  apply (drule_tac s="Max is" in sym)
  apply simp
  apply (case_tac "card is \<le> 1")
  apply simp
  apply (drule iseq_diff)
  apply (drule_tac i="Suc (Max (is - {Max is}))" and j="Max is" in iseq_mono)
  apply (simp add: less_eq_Suc_le [symmetric])
  apply (rule Max_diff)
  apply simp
  apply (drule_tac x="is - {Max is}" in meta_spec,
    drule meta_mp, assumption)
  apply simp
  done

lemma longest_iseq3:
  "liseq xs j = liseq' xs i \<Longrightarrow> xs i \<le> xs j \<Longrightarrow> i < j \<Longrightarrow>
  liseq xs (Suc j) = liseq xs j + 1"
  apply (rule_tac xs=xs and i=j in liseq_expand)
  apply simp
  apply (rule_tac xs=xs and i=i in liseq'_expand)
  apply simp
  apply (rule_tac js="isa \<union> {j}" in liseq_eq [symmetric])
  apply (simp add: card_insert card_Diff_singleton_if max_notin)
  apply (rule iseq_insert)
  apply simp
  apply (erule iseq_mono)
  apply simp
  apply (case_tac "j = Max js'")
  apply simp
  apply (drule iseq_diff)
  apply (drule_tac x="js' - {j}" in meta_spec)
  apply (drule meta_mp)
  apply simp
  apply (case_tac "card js' \<le> 1")
  apply (erule_tac xs=js' in card_leq1_singleton)
  apply assumption+
  apply (simp add: iseq_trivial)
  apply (erule iseq_mono)
  apply (simp add: less_eq_Suc_le [symmetric])
  apply (rule Max_diff)
  apply simp
  apply (rule le_diff_iff [THEN iffD1, of 1])
  apply (simp add: card_0_eq [symmetric] del: card_0_eq)
  apply (simp add: card_insert)
  apply (subgoal_tac "card (js' - {j}) = card js' - 1")
  apply (simp add: card_insert card_Diff_singleton_if max_notin)
  apply (frule_tac A=js' in Max_in)
  apply assumption
  apply (simp add: card_Diff_singleton_if)
  apply (drule_tac js=js' in iseq_butlast)
  apply assumption
  apply (erule not_sym)
  apply (drule_tac x=js' in meta_spec)
  apply (drule meta_mp)
  apply assumption
  apply (simp add: card_insert_disjoint max_notin)
  done

lemma longest_iseq4:
  "liseq xs j = liseq' xs i \<Longrightarrow> xs i \<le> xs j \<Longrightarrow> i < j \<Longrightarrow>
  liseq' xs j = liseq' xs i + 1"
  apply (rule_tac xs=xs and i=j in liseq_expand)
  apply simp
  apply (rule_tac xs=xs and i=i in liseq'_expand)
  apply simp
  apply (rule_tac js="isa \<union> {j}" in liseq'_eq [symmetric])
  apply (simp add: card_insert card_Diff_singleton_if max_notin)
  apply (rule iseq_insert)
  apply simp
  apply (erule iseq_mono)
  apply simp
  apply simp
  apply simp
  apply (drule_tac s="Max js'" in sym)
  apply simp
  apply (drule iseq_diff)
  apply (drule_tac x="js' - {j}" in meta_spec)
  apply (drule meta_mp)
  apply simp
  apply (case_tac "card js' \<le> 1")
  apply (erule_tac xs=js' in card_leq1_singleton)
  apply assumption+
  apply (simp add: iseq_trivial)
  apply (erule iseq_mono)
  apply (simp add: less_eq_Suc_le [symmetric])
  apply (rule Max_diff)
  apply simp
  apply (rule le_diff_iff [THEN iffD1, of 1])
  apply (simp add: card_0_eq [symmetric] del: card_0_eq)
  apply (simp add: card_insert)
  apply (subgoal_tac "card (js' - {j}) = card js' - 1")
  apply (simp add: card_insert card_Diff_singleton_if max_notin)
  apply (frule_tac A=js' in Max_in)
  apply assumption
  apply (simp add: card_Diff_singleton_if)
  done

lemma longest_iseq5: "liseq' xs i \<le> liseq xs i \<Longrightarrow>
  liseq xs (Suc i) = liseq xs i"
  apply (rule_tac i=i and xs=xs in liseq'_expand)
  apply simp
  apply (rule_tac xs=xs and i=i in liseq_expand)
  apply simp
  apply (rule liseq_eq [symmetric])
  apply (rule refl)
  apply (erule iseq_mono)
  apply simp
  apply (case_tac "Max js' = i")
  apply (drule_tac x=js' in meta_spec)
  apply simp
  apply (drule iseq_butlast, assumption, assumption)
  apply simp
  done

lemma liseq_empty: "liseq xs 0 = 0"
  apply (rule_tac js="{}" in liseq_eq [symmetric])
  apply simp
  apply (rule iseq_trivial)
  apply (simp add: iseq_def)
  done

lemma liseq'_singleton: "liseq' xs 0 = 1"
  by (simp add: longest_iseq1 [of _ 0])

lemma liseq_singleton: "liseq xs (Suc 0) = Suc 0"
  by (simp add: longest_iseq2' liseq_empty liseq'_singleton)

lemma liseq'_Suc_unfold:
  "A j \<le> x \<Longrightarrow>
   (insert 0 {liseq' A j' |j'. j' < Suc j \<and> A j' \<le> x}) =
   (insert 0 {liseq' A j' |j'. j' < j \<and> A j' \<le> x}) \<union>
   {liseq' A j}"
  by (auto simp add: less_Suc_eq)

lemma liseq'_Suc_unfold':
  "\<not> (A j \<le> x) \<Longrightarrow>
   {liseq' A j' |j'. j' < Suc j \<and> A j' \<le> x} =
   {liseq' A j' |j'. j' < j \<and> A j' \<le> x}"
  by (auto simp add: less_Suc_eq)

lemma iseq_card_limit:
  assumes "is \<in> iseq A i"
  shows "card is \<le> i"
proof -
  from assms have "is \<subseteq> {0..<i}"
    by (auto simp add: iseq_def)
  with finite_atLeastLessThan have "card is \<le> card {0..<i}"
    by (rule card_mono)
  with card_atLeastLessThan show ?thesis by simp
qed

lemma liseq_limit: "liseq A i \<le> i"
  by (rule_tac xs=A and i=i in liseq_expand)
    (simp add: iseq_card_limit)

lemma liseq'_limit: "liseq' A i \<le> i + 1"
  by (rule_tac xs=A and i=i in liseq'_expand)
    (simp add: iseq_card_limit)

definition max_ext :: "(nat \<Rightarrow> 'a::linorder) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "max_ext A i j = Max ({0} \<union> {liseq' A j' |j'. j' < j \<and> A j' \<le> A i})"

lemma max_ext_limit: "max_ext A i j \<le> j"
  apply (auto simp add: max_ext_def)
  apply (drule Suc_leI)
  apply (cut_tac i=j' and A=A in liseq'_limit)
  apply simp
  done

text {* Proof functions *}

abbreviation (input)
  "arr_conv a \<equiv> (\<lambda>n. a (int n))"

lemma idx_conv_suc:
  "0 \<le> i \<Longrightarrow> nat (i + 1) = nat i + 1"
  by simp

abbreviation liseq_ends_at' :: "(int \<Rightarrow> 'a::linorder) \<Rightarrow> int \<Rightarrow> int" where
  "liseq_ends_at' A i \<equiv> int (liseq' (\<lambda>l. A (int l)) (nat i))"

abbreviation liseq_prfx' :: "(int \<Rightarrow> 'a::linorder) \<Rightarrow> int \<Rightarrow> int" where
  "liseq_prfx' A i \<equiv> int (liseq (\<lambda>l. A (int l)) (nat i))"

abbreviation max_ext' :: "(int \<Rightarrow> 'a::linorder) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int" where
  "max_ext' A i j \<equiv> int (max_ext (\<lambda>l. A (int l)) (nat i) (nat j))"

spark_proof_functions
  liseq_ends_at = "liseq_ends_at' :: (int \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> int"
  liseq_prfx = "liseq_prfx' :: (int \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> int"
  max_ext = "max_ext' :: (int \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int"

text {* The verification conditions *}

spark_open "liseq/liseq_length"

spark_vc procedure_liseq_length_5
  by (simp_all add: liseq_singleton liseq'_singleton)

spark_vc procedure_liseq_length_6
proof -
  from H1 H2 H3 H4
  have eq: "liseq (arr_conv a) (nat i) =
    liseq' (arr_conv a) (nat pmax)"
    by simp
  from H14 H3 H4
  have pmax1: "arr_conv a (nat pmax) \<le> arr_conv a (nat i)"
    by simp
  from H3 H4 have pmax2: "nat pmax < nat i"
    by simp
  {
    fix i2
    assume i2: "0 \<le> i2" "i2 \<le> i"
    have "(l(i := l pmax + 1)) i2 =
      int (liseq' (arr_conv a) (nat i2))"
    proof (cases "i2 = i")
      case True
      from eq pmax1 pmax2 have "liseq' (arr_conv a) (nat i) =
        liseq' (arr_conv a) (nat pmax) + 1"
        by (rule longest_iseq4)
      with True H1 H3 H4 show ?thesis
        by simp
    next
      case False
      with H1 i2 show ?thesis
        by simp
    qed
  }
  then show ?C1 by simp
  from eq pmax1 pmax2
  have "liseq (arr_conv a) (Suc (nat i)) =
    liseq (arr_conv a) (nat i) + 1"
    by (rule longest_iseq3)
 with H2 H3 H4 show ?C2
    by (simp add: idx_conv_suc)
qed

spark_vc procedure_liseq_length_7
proof -
  from H1 show ?C1
    by (simp add: max_ext_def longest_iseq1 [of _ "nat i"])
  from H6
  have m: "max_ext (arr_conv a) (nat i) (nat i) + 1 =
    liseq' (arr_conv a) (nat i)"
    by (simp add: max_ext_def longest_iseq1 [of _ "nat i"])
  with H2 H18
  have gt: "liseq (arr_conv a) (nat i) < liseq' (arr_conv a) (nat i)"
    by simp
  then have "liseq' (arr_conv a) (nat i) = liseq (arr_conv a) (nat i) + 1"
    by (rule longest_iseq2 [symmetric])
  with H2 m show ?C2 by simp
  from gt have "liseq (arr_conv a) (Suc (nat i)) = liseq' (arr_conv a) (nat i)"
    by (rule longest_iseq2')
  with m H6 show ?C3 by (simp add: idx_conv_suc)
qed

spark_vc procedure_liseq_length_8
proof -
  {
    fix i2
    assume i2: "0 \<le> i2" "i2 \<le> i"
    have "(l(i := max_ext' a i i + 1)) i2 =
      int (liseq' (arr_conv a) (nat i2))"
    proof (cases "i2 = i")
      case True
      with H1 show ?thesis
        by (simp add: max_ext_def longest_iseq1 [of _ "nat i"])
    next
      case False
      with H1 i2 show ?thesis by simp
    qed
  }
  then show ?C1 by simp
  from H2 H6 H18
  have "liseq' (arr_conv a) (nat i) \<le> liseq (arr_conv a) (nat i)"
    by (simp add: max_ext_def longest_iseq1 [of _ "nat i"])
  then have "liseq (arr_conv a) (Suc (nat i)) = liseq (arr_conv a) (nat i)"
    by (rule longest_iseq5)
  with H2 H6 show ?C2 by (simp add: idx_conv_suc)
qed

spark_vc procedure_liseq_length_12
  by (simp add: max_ext_def)

spark_vc procedure_liseq_length_13
  using H1 H6 H13 H21 H22
  by (simp add: max_ext_def
    idx_conv_suc liseq'_Suc_unfold max_def del: Max_less_iff)

spark_vc procedure_liseq_length_14
  using H1 H6 H13 H21
  by (cases "a j \<le> a i")
    (simp_all add: max_ext_def
      idx_conv_suc liseq'_Suc_unfold liseq'_Suc_unfold')

spark_vc procedure_liseq_length_19
  using H3 H4 H5 H8 H9
  apply (rule_tac y="int (nat i)" in order_trans)
  apply (cut_tac A="arr_conv a" and i="nat i" and j="nat i" in max_ext_limit)
  apply simp_all
  done

spark_vc procedure_liseq_length_23
  using H2 H3 H4 H7 H8 H11
  apply (rule_tac y="int (nat i)" in order_trans)
  apply (cut_tac A="arr_conv a" and i="nat i" in liseq_limit)
  apply simp_all
  done

spark_vc procedure_liseq_length_29
  using H2 H3 H8 H13
  by (simp add: add1_zle_eq [symmetric])

spark_end

end


theory Report_demo imports
  "../Norm_proofs"
  "~~/src/HOL/Library/LaTeXsugar"
begin

definition test_gr :: "(nat, nat) grammar" where
  "test_gr =
   [(1, [(0, [])]),
    (2, [(0, [1])]),
    (3, [(0, [2])]),
    (4, [(0, [1, 1, 1])]),
    (5, [(23, [3]), (24, [4])])]"

text {*
Let us first see what happens when we run the norm iteration algorithm without refinement ---
recall that this results in a mere overestimation of the final norms:
*}

lemma "iterate_norms test_gr =
  ([(1, 1, 0, []),
    (2, 2, 0, [1]),
    (4, 4, 0, [1, 1, 1]),
    (3, 3, 0, [2]),
    (5, 5, 24, [4])],
   [])"
by eval

text {*
In the results of the algorithm, we first note that the grammar is normed, because all
variables have a finite norm, which is indicated by the empty list in the second component
of the result pair.

Now we compare the output from the norm iteration algorithm with the output from
the norm iteration algorithm with added refinement at the end.
*}

lemma "norms_of_grammar test_gr =
  [(1, 1, 0, []),
   (2, 2, 0, [1]),
   (4, 4, 0, [1, 1, 1]),
   (3, 3, 0, [2]),
   (5, 4, 23, [3])]"
by eval

text {*
Comparing the two results, we note that the last norm entries, namely those
concering variable 5, differ. That means that the refinement found a smaller
norm for variable 5 than the overestimation algorithm.

Finally, we can also calculate the norm of variable words:
*}

lemma "norm_fun test_gr [1, 3, 5] = 8" by eval

end


section \<open>Normalizing Derivative\<close>

theory NDerivative
imports
  Regular_Exp
begin

subsection \<open>Normalizing operations\<close>

text \<open>associativity, commutativity, idempotence, zero\<close>

fun nPlus :: "'a::order rexp \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp"
where
  "nPlus Zero r = r"
| "nPlus r Zero = r"
| "nPlus (Plus r s) t = nPlus r (nPlus s t)"
| "nPlus r (Plus s t) =
     (if r = s then (Plus s t)
     else if le_rexp r s then Plus r (Plus s t)
     else Plus s (nPlus r t))"
| "nPlus r s =
     (if r = s then r
      else if le_rexp r s then Plus r s
      else Plus s r)"

lemma lang_nPlus[simp]: "lang (nPlus r s) = lang (Plus r s)"
by (induction r s rule: nPlus.induct) auto

text \<open>associativity, zero, one\<close>

fun nTimes :: "'a::order rexp \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp"
where
  "nTimes Zero _ = Zero"
| "nTimes _ Zero = Zero"
| "nTimes One r = r"
| "nTimes r One = r"
| "nTimes (Times r s) t = Times r (nTimes s t)"
| "nTimes r s = Times r s"

lemma lang_nTimes[simp]: "lang (nTimes r s) = lang (Times r s)"
by (induction r s rule: nTimes.induct) (auto simp: conc_assoc)

primrec norm :: "'a::order rexp \<Rightarrow> 'a rexp"
where
  "norm Zero = Zero"
| "norm One = One"
| "norm (Atom a) = Atom a"
| "norm (Plus r s) = nPlus (norm r) (norm s)"
| "norm (Times r s) = nTimes (norm r) (norm s)"
| "norm (Star r) = Star (norm r)"

lemma lang_norm[simp]: "lang (norm r) = lang r"
by (induct r) auto

primrec nderiv :: "'a::order \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp"
where
  "nderiv _ Zero = Zero"
| "nderiv _ One = Zero"
| "nderiv a (Atom b) = (if a = b then One else Zero)"
| "nderiv a (Plus r s) = nPlus (nderiv a r) (nderiv a s)"
| "nderiv a (Times r s) =
    (let r's = nTimes (nderiv a r) s
     in if nullable r then nPlus r's (nderiv a s) else r's)"
| "nderiv a (Star r) = nTimes (nderiv a r) (Star r)"

lemma lang_nderiv: "lang (nderiv a r) = Deriv a (lang r)"
by (induction r) (auto simp: Let_def nullable_iff)

lemma deriv_no_occurrence:
  "x \<notin> atoms r \<Longrightarrow> nderiv x r = Zero"
by (induction r) auto

lemma atoms_nPlus[simp]: "atoms (nPlus r s) = atoms r \<union> atoms s"
by (induction r s rule: nPlus.induct) auto

lemma atoms_nTimes: "atoms (nTimes r s) \<subseteq> atoms r \<union> atoms s"
by (induction r s rule: nTimes.induct) auto

lemma atoms_norm: "atoms (norm r) \<subseteq> atoms r"
by (induction r) (auto dest!:subsetD[OF atoms_nTimes])

lemma atoms_nderiv: "atoms (nderiv a r) \<subseteq> atoms r"
by (induction r) (auto simp: Let_def dest!:subsetD[OF atoms_nTimes])

end


(*  Title:       Verification Examples
    Author:      Jonathan Julián Huerta y Munive, 2021
    Maintainer:  Jonathan Julián Huerta y Munive <jonjulian23@gmail.com>
*)

section \<open> Verification examples \<close>

theory MTX_Examples
  imports
    MTX_Flows
    Hybrid_Systems_VCs.HS_VC_Spartan

begin

subsection \<open> Examples \<close>

abbreviation hoareT :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a set) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
  ("PRE_ HP _ POST _" [85,85]85) where "PRE P HP X POST Q \<equiv> (P \<le> |X]Q)"

subsubsection \<open> Verification by uniqueness. \<close>

abbreviation mtx_circ :: "2 sq_mtx" ("A")
  where "A \<equiv> mtx
   ([0,  1] #
    [-1, 0] # [])"

abbreviation mtx_circ_flow :: "real \<Rightarrow> real^2 \<Rightarrow> real^2" ("\<phi>")
  where "\<phi> t s \<equiv> (\<chi> i. if i = 1 then s$1 * cos t + s$2 * sin t else - s$1 * sin t + s$2 * cos t)"

lemma mtx_circ_flow_eq: "exp (t *\<^sub>R A) *\<^sub>V s = \<phi> t s"
  apply(rule local_flow.eq_solution[OF local_flow_sq_mtx_linear, symmetric, of _ "\<lambda>s. UNIV"], simp_all)
    apply(rule ivp_solsI, simp_all add: sq_mtx_vec_mult_eq vec_eq_iff)
  unfolding UNIV_2 using exhaust_2
  by (force intro!: poly_derivatives simp: matrix_vector_mult_def)+

lemma mtx_circ:
  "PRE(\<lambda>s. r\<^sup>2 = (s $ 1)\<^sup>2 + (s $ 2)\<^sup>2)
  HP x\<acute>=(*\<^sub>V) A & G
  POST (\<lambda>s. r\<^sup>2 = (s $ 1)\<^sup>2 + (s $ 2)\<^sup>2)"
  apply(subst local_flow.fbox_g_ode_subset[OF local_flow_sq_mtx_linear])
  unfolding mtx_circ_flow_eq by auto

no_notation mtx_circ ("A")
        and mtx_circ_flow ("\<phi>")

subsubsection \<open> Flow of diagonalisable matrix. \<close>

abbreviation mtx_hOsc :: "real \<Rightarrow> real \<Rightarrow> 2 sq_mtx" ("A")
  where "A a b \<equiv> mtx
   ([0, 1] #
    [a, b] # [])"

abbreviation mtx_chB_hOsc :: "real \<Rightarrow> real \<Rightarrow> 2 sq_mtx" ("P")
  where "P a b \<equiv> mtx
   ([a, b] #
    [1, 1] # [])"

lemma inv_mtx_chB_hOsc:
  "a \<noteq> b \<Longrightarrow> (P a b)\<^sup>-\<^sup>1 = (1/(a - b)) *\<^sub>R mtx
   ([ 1, -b] #
    [-1,  a] # [])"
  apply(rule sq_mtx_inv_unique, unfold scaleR_mtx2 times_mtx2)
  by (simp add: diff_divide_distrib[symmetric] one_mtx2)+

lemma invertible_mtx_chB_hOsc: "a \<noteq> b \<Longrightarrow> mtx_invertible (P a b)"
  apply(rule mtx_invertibleI[of _ "(P a b)\<^sup>-\<^sup>1"])
   apply(unfold inv_mtx_chB_hOsc scaleR_mtx2 times_mtx2 one_mtx2)
  by (subst sq_mtx_eq_iff, simp add: vector_def frac_diff_eq1)+

lemma mtx_hOsc_diagonalizable:
  fixes a b :: real
  defines "\<iota>\<^sub>1 \<equiv> (b - sqrt (b^2+4*a))/2" and "\<iota>\<^sub>2 \<equiv> (b + sqrt (b^2+4*a))/2"
  assumes "b\<^sup>2 + a * 4 > 0" and "a \<noteq> 0"
  shows "A a b = P (-\<iota>\<^sub>2/a) (-\<iota>\<^sub>1/a) * (\<d>\<i>\<a>\<g> i. if i = 1 then \<iota>\<^sub>1 else \<iota>\<^sub>2) * (P (-\<iota>\<^sub>2/a) (-\<iota>\<^sub>1/a))\<^sup>-\<^sup>1"
  unfolding assms apply(subst inv_mtx_chB_hOsc)
  using assms(3,4) apply(simp_all add: diag2_eq[symmetric])
  unfolding sq_mtx_times_eq sq_mtx_scaleR_eq UNIV_2 apply(subst sq_mtx_eq_iff)
  using exhaust_2 assms by (auto simp: field_simps, auto simp: field_power_simps)

lemma mtx_hOsc_solution_eq:
  fixes a b :: real
  defines "\<iota>\<^sub>1 \<equiv> (b - sqrt (b\<^sup>2+4*a))/2" and "\<iota>\<^sub>2 \<equiv> (b + sqrt (b\<^sup>2+4*a))/2"
  defines "\<Phi> t \<equiv> mtx (
   [\<iota>\<^sub>2*exp(t*\<iota>\<^sub>1) - \<iota>\<^sub>1*exp(t*\<iota>\<^sub>2),     exp(t*\<iota>\<^sub>2)-exp(t*\<iota>\<^sub>1)]#
   [a*exp(t*\<iota>\<^sub>2) - a*exp(t*\<iota>\<^sub>1), \<iota>\<^sub>2*exp(t*\<iota>\<^sub>2)-\<iota>\<^sub>1*exp(t*\<iota>\<^sub>1)]#[])"
  assumes "b\<^sup>2 + a * 4 > 0" and "a \<noteq> 0"
  shows "P (-\<iota>\<^sub>2/a) (-\<iota>\<^sub>1/a) * (\<d>\<i>\<a>\<g> i. exp (t * (if i=1 then \<iota>\<^sub>1 else \<iota>\<^sub>2))) * (P (-\<iota>\<^sub>2/a) (-\<iota>\<^sub>1/a))\<^sup>-\<^sup>1
  = (1/sqrt (b\<^sup>2 + a * 4)) *\<^sub>R (\<Phi> t)"
  unfolding assms apply(subst inv_mtx_chB_hOsc)
  using assms apply(simp_all add: mtx_times_scaleR_commute, subst sq_mtx_eq_iff)
  unfolding UNIV_2 sq_mtx_times_eq sq_mtx_scaleR_eq sq_mtx_uminus_eq apply(simp_all add: axis_def)
  by (auto simp: field_simps, auto simp: field_power_simps)+

lemma local_flow_mtx_hOsc:
  fixes a b
  defines "\<iota>\<^sub>1 \<equiv> (b - sqrt (b^2+4*a))/2" and "\<iota>\<^sub>2 \<equiv> (b + sqrt (b^2+4*a))/2"
  defines "\<Phi> t \<equiv> mtx (
   [\<iota>\<^sub>2*exp(t*\<iota>\<^sub>1) - \<iota>\<^sub>1*exp(t*\<iota>\<^sub>2),     exp(t*\<iota>\<^sub>2)-exp(t*\<iota>\<^sub>1)]#
   [a*exp(t*\<iota>\<^sub>2) - a*exp(t*\<iota>\<^sub>1), \<iota>\<^sub>2*exp(t*\<iota>\<^sub>2)-\<iota>\<^sub>1*exp(t*\<iota>\<^sub>1)]#[])"
  assumes "b\<^sup>2 + a * 4 > 0" and "a \<noteq> 0"
  shows "local_flow ((*\<^sub>V) (A a b)) UNIV UNIV (\<lambda>t. (*\<^sub>V) ((1/sqrt (b\<^sup>2 + a * 4)) *\<^sub>R \<Phi> t))"
  unfolding assms using local_flow_sq_mtx_linear[of "A a b"] assms
  apply(subst (asm) exp_scaleR_diagonal2[OF invertible_mtx_chB_hOsc mtx_hOsc_diagonalizable])
     apply(simp, simp, simp)
  by (subst (asm) mtx_hOsc_solution_eq) simp_all

lemma overdamped_door_arith:
  assumes "b\<^sup>2 + a * 4 > 0" and "a < 0" and "b \<le> 0" and "t \<ge> 0" and "s1 > 0"
  shows "0 \<le> ((b + sqrt (b\<^sup>2 + 4 * a)) * exp (t * (b - sqrt (b\<^sup>2 + 4 * a)) / 2) / 2 -
(b - sqrt (b\<^sup>2 + 4 * a)) * exp (t * (b + sqrt (b\<^sup>2 + 4 * a)) / 2) / 2) * s1 / sqrt (b\<^sup>2 + a * 4)"
proof(subst diff_divide_distrib[symmetric], simp)
  have f0: "s1 / (2 * sqrt (b\<^sup>2 + a * 4)) > 0"  (is "s1/?c3 > 0")
    using assms(1,5) by simp
  have f1: "(b - sqrt (b\<^sup>2 + 4 * a)) < (b + sqrt (b\<^sup>2 + 4 * a))" (is "?c2 < ?c1")
    and f2: "(b + sqrt (b\<^sup>2 + 4 * a)) < 0"
    using sqrt_ge_absD[of b "b\<^sup>2 + 4 * a"] assms by (force, linarith)
  hence f3: "exp (t * ?c2 / 2) \<le> exp (t * ?c1 / 2)" (is "exp ?t1 \<le> exp ?t2")
    unfolding exp_le_cancel_iff
    using assms(4) by (case_tac "t=0", simp_all)
  hence "?c2 * exp ?t2 \<le> ?c2 * exp ?t1"
    using f1 f2 mult_le_cancel_left_pos[of "-?c2" "exp ?t1" "exp ?t2"] by linarith
  also have "... < ?c1 * exp ?t1"
    using f1 by auto
  also have"... \<le> ?c1 * exp ?t1"
    using f1 f2 by auto
  ultimately show "0 \<le> (?c1 * exp ?t1 - ?c2 * exp ?t2) * s1 / ?c3"
    using f0 f1 assms(5) by auto
qed

abbreviation "open_door s \<equiv> {s. s$1 > 0 \<and> s$2 = 0}"

lemma overdamped_door:
  assumes "b\<^sup>2 + a * 4 > 0" and "a < 0" and "b \<le> 0"
  shows "PRE (\<lambda>s. s$1 = 0)
  HP (LOOP open_door; (x\<acute>=((*\<^sub>V) (A a b)) & G) INV (\<lambda>s. 0 \<le> s$1))
  POST (\<lambda>s. 0 \<le> s $ 1)"
  apply(rule fbox_loopI, simp_all add: le_fun_def)
  apply(subst local_flow.fbox_g_ode_subset[OF local_flow_mtx_hOsc[OF assms(1)]])
  using assms apply(simp_all add: le_fun_def fbox_def)
  unfolding sq_mtx_scaleR_eq UNIV_2 sq_mtx_vec_mult_eq
  by (clarsimp simp: overdamped_door_arith)

no_notation mtx_hOsc ("A")
        and mtx_chB_hOsc ("P")

subsubsection \<open> Flow of non-diagonalisable matrix. \<close>

abbreviation mtx_cnst_acc :: "3 sq_mtx" ("K")
  where "K \<equiv> mtx (
  [0,1,0] #
  [0,0,1] #
  [0,0,0] # [])"

lemma pow2_scaleR_mtx_cnst_acc: "(t *\<^sub>R K)\<^sup>2 = mtx (
  [0,0,t\<^sup>2] #
  [0,0,0] #
  [0,0,0] # [])"
  unfolding power2_eq_square apply(subst sq_mtx_eq_iff)
  unfolding sq_mtx_times_eq UNIV_3 by auto

lemma powN_scaleR_mtx_cnst_acc: "n > 2 \<Longrightarrow> (t *\<^sub>R K)^n = 0"
  apply(induct n, simp, case_tac "n \<le> 2")
   apply(subgoal_tac "n = 2", erule ssubst)
  unfolding power_Suc2 pow2_scaleR_mtx_cnst_acc sq_mtx_times_eq UNIV_3
  by (auto simp: sq_mtx_eq_iff)

lemma exp_mtx_cnst_acc_vec_mult_eq: "exp (t *\<^sub>R K) *\<^sub>V s =
  vector [s$3 * t^2/2 + s$2 * t + s$1, s$3 * t + s$2, s$3]"
  apply(subst exp_mtx_cnst_acc, subst pow2_scaleR_mtx_cnst_acc)
  apply(simp add: sq_mtx_vec_mult_eq vector_def)
  unfolding UNIV_3 by (simp add: fun_eq_iff)

lemma local_flow_mtx_cnst_acc:
  "local_flow ((*\<^sub>V) K) UNIV UNIV (\<lambda>t s. ((t *\<^sub>R K)\<^sup>2/\<^sub>R 2 + (t *\<^sub>R K) + 1) *\<^sub>V s)"
  using local_flow_sq_mtx_linear[of K] unfolding exp_mtx_cnst_acc .

lemma docking_station_arith:
  assumes "(d::real) > x" and "v > 0"
  shows "(v = v\<^sup>2 * t / (2 * d - 2 * x)) \<longleftrightarrow> (v * t - v\<^sup>2 * t\<^sup>2 / (4 * d - 4 * x) + x = d)"
proof
  assume "v = v\<^sup>2 * t / (2 * d - 2 * x)"
  hence "v * t = 2 * (d - x)"
    using assms by (simp add: eq_divide_eq power2_eq_square)
  hence "v * t - v\<^sup>2 * t\<^sup>2 / (4 * d - 4 * x) + x = 2 * (d - x) - 4 * (d - x)\<^sup>2 / (4 * (d - x)) + x"
    apply(subst power_mult_distrib[symmetric])
    by (erule ssubst, subst power_mult_distrib, simp)
  also have "... = d"
    apply(simp only: mult_divide_mult_cancel_left_if)
    using assms by (auto simp: power2_eq_square)
  finally show "v * t - v\<^sup>2 * t\<^sup>2 / (4 * d - 4 * x) + x = d" .
next
  assume "v * t - v\<^sup>2 * t\<^sup>2 / (4 * d - 4 * x) + x = d"
  hence "0 = v\<^sup>2 * t\<^sup>2 / (4 * (d - x)) + (d - x) - v * t"
    by auto
  hence "0 = (4 * (d - x)) * (v\<^sup>2 * t\<^sup>2 / (4 * (d - x)) + (d - x) - v * t)"
    by auto
  also have "... = v\<^sup>2 * t\<^sup>2 + 4 * (d - x)\<^sup>2  - (4 * (d - x)) * (v * t)"
    using assms apply(simp add: distrib_left right_diff_distrib)
    apply(subst right_diff_distrib[symmetric])+
    by (simp add: power2_eq_square)
  also have "... = (v * t - 2 * (d - x))\<^sup>2"
    by (simp only: power2_diff, auto simp: field_simps power2_diff)
  finally have "0 = (v * t - 2 * (d - x))\<^sup>2" .
  hence "v * t = 2 * (d - x)"
    by auto
  thus "v = v\<^sup>2 * t / (2 * d - 2 * x)"
    apply(subst power2_eq_square, subst mult.assoc)
    apply(erule ssubst, subst right_diff_distrib[symmetric])
    using assms by auto
qed

lemma docking_station:
  assumes "d > x\<^sub>0" and "v\<^sub>0 > 0"
  shows "PRE (\<lambda>s. s$1 = x\<^sub>0 \<and> s$2 = v\<^sub>0)
  HP ((3 ::= (\<lambda>s. -(v\<^sub>0^2/(2*(d-x\<^sub>0))))); x\<acute>=(*\<^sub>V) K & G)
  POST (\<lambda>s. s$2 = 0 \<longleftrightarrow> s$1 = d)"
  apply(clarsimp simp: le_fun_def local_flow.fbox_g_ode_subset[OF local_flow_sq_mtx_linear[of K]])
  unfolding exp_mtx_cnst_acc_vec_mult_eq using assms by (simp add: docking_station_arith)

no_notation mtx_cnst_acc ("K")

end


section "Security Type Systems"

subsection "Security Levels and Expressions"

theory Sec_Type_Expr imports Big_Step
begin

type_synonym level = nat

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

text\<open>The security/confidentiality level of each variable is globally fixed
for simplicity. For the sake of examples --- the general theory does not rely
on it! --- a variable of length \<open>n\<close> has security level \<open>n\<close>:\<close>

instantiation list :: (type)sec
begin

definition "sec(x :: 'a list) = length x"

instance ..

end

instantiation aexp :: sec
begin

fun sec_aexp :: "aexp \<Rightarrow> level" where
"sec (N n) = 0" |
"sec (V x) = sec x" |
"sec (Plus a\<^sub>1 a\<^sub>2) = max (sec a\<^sub>1) (sec a\<^sub>2)"

instance ..

end

instantiation bexp :: sec
begin

fun sec_bexp :: "bexp \<Rightarrow> level" where
"sec (Bc v) = 0" |
"sec (Not b) = sec b" |
"sec (And b\<^sub>1 b\<^sub>2) = max (sec b\<^sub>1) (sec b\<^sub>2)" |
"sec (Less a\<^sub>1 a\<^sub>2) = max (sec a\<^sub>1) (sec a\<^sub>2)"

instance ..

end

abbreviation eq_le :: "state \<Rightarrow> state \<Rightarrow> level \<Rightarrow> bool"
  ("(_ = _ '(\<le> _'))" [51,51,0] 50) where
"s = s' (\<le> l) == (\<forall> x. sec x \<le> l \<longrightarrow> s x = s' x)"

abbreviation eq_less :: "state \<Rightarrow> state \<Rightarrow> level \<Rightarrow> bool"
  ("(_ = _ '(< _'))" [51,51,0] 50) where
"s = s' (< l) == (\<forall> x. sec x < l \<longrightarrow> s x = s' x)"

lemma aval_eq_if_eq_le:
  "\<lbrakk> s\<^sub>1 = s\<^sub>2 (\<le> l);  sec a \<le> l \<rbrakk> \<Longrightarrow> aval a s\<^sub>1 = aval a s\<^sub>2"
by (induct a) auto

lemma bval_eq_if_eq_le:
  "\<lbrakk> s\<^sub>1 = s\<^sub>2 (\<le> l);  sec b \<le> l \<rbrakk> \<Longrightarrow> bval b s\<^sub>1 = bval b s\<^sub>2"
by (induct b) (auto simp add: aval_eq_if_eq_le)

end