(*  Title:      Prefix_Match.thy
    Authors:    Julius Michaelis, Cornelius Diekmann
*)
theory Prefix_Match
imports IP_Address
begin

section\<open>Prefix Match\<close>
text\<open>
  The main difference between the prefix match defined here and CIDR notation is a validity
  constraint imposed on prefix matches.

  For example, 192.168.42.42/16 is valid CIDR notation whereas for a prefix match,
  it must be 192.168.0.0/16.

  I.e. the last bits of the prefix must be set to zero.
\<close>

context
  notes [[typedef_overloaded]]
begin
  datatype 'a prefix_match = PrefixMatch (pfxm_prefix: "'a::len word") (pfxm_length: nat)
end

definition pfxm_mask :: "'a prefix_match \<Rightarrow> 'a::len word" where
  "pfxm_mask x \<equiv> mask (len_of (TYPE('a)) - pfxm_length x)"

definition valid_prefix :: "('a::len) prefix_match \<Rightarrow> bool" where
  "valid_prefix pf = ((pfxm_mask pf) AND pfxm_prefix pf = 0)"
text\<open>Note that @{const valid_prefix} looks very elegant as a definition. However, it hides something nasty:\<close>
lemma "valid_prefix (PrefixMatch (0::32 word) 42)" by eval

text\<open>When zeroing all least significant bits which exceed the @{const pfxm_length},
     you get a @{const valid_prefix}\<close>
lemma mk_valid_prefix:
  fixes base::"'a::len word"
  shows "valid_prefix (PrefixMatch (base AND NOT (mask (len_of TYPE ('a) - len))) len)"
proof -
  have "mask (len - m) AND base AND NOT (mask (len - m)) = 0"
    for m len and base::"'a::len word" by(simp add: word_bw_lcs)
  thus ?thesis
  by(simp add: valid_prefix_def pfxm_mask_def pfxm_length_def pfxm_prefix_def)
qed

text\<open>The type @{typ "'a prefix_match"} usually requires @{const valid_prefix}.
      When we allow working on arbitrary IPs in CIDR notation,
      we will use the type @{typ "('i::len word \<times> nat)"} directly.\<close>

lemma valid_prefix_00: "valid_prefix (PrefixMatch 0 0)" by (simp add: valid_prefix_def)

definition prefix_match_to_CIDR :: "('i::len) prefix_match \<Rightarrow> ('i word \<times> nat)" where
  "prefix_match_to_CIDR pfx \<equiv> (pfxm_prefix pfx, pfxm_length pfx)"

lemma prefix_match_to_CIDR_def2: "prefix_match_to_CIDR = (\<lambda>pfx. (pfxm_prefix pfx, pfxm_length pfx))"
  unfolding prefix_match_to_CIDR_def fun_eq_iff by simp

definition "prefix_match_dtor m \<equiv> (case m of PrefixMatch p l \<Rightarrow> (p,l))"

text\<open>Some more or less random linear order on prefixes.
     Only used for serialization at the time of this writing.\<close>
instantiation prefix_match :: (len) linorder
begin
	definition "a \<le> b \<longleftrightarrow> (if pfxm_length a = pfxm_length b
                         then pfxm_prefix a \<le> pfxm_prefix b
                         else pfxm_length a > pfxm_length b)"
	definition "a < b \<longleftrightarrow> (a \<noteq> b \<and>
	                       (if pfxm_length a = pfxm_length b
	                        then pfxm_prefix a \<le> pfxm_prefix b
	                        else pfxm_length a > pfxm_length b))"
instance
by standard (auto simp: less_eq_prefix_match_def less_prefix_match_def prefix_match.expand
                  split: if_splits)
end

lemma "sorted_list_of_set
 {PrefixMatch 0 32 :: 32 prefix_match,
  PrefixMatch 42 32,
  PrefixMatch 0 0,
  PrefixMatch 0 1,
  PrefixMatch 12 31} =
    [PrefixMatch 0 32, PrefixMatch 0x2A 32, PrefixMatch 0xC 31, PrefixMatch 0 1, PrefixMatch 0 0]"
  by eval

context
begin

private lemma valid_prefix_E: "valid_prefix pf \<Longrightarrow> ((pfxm_mask pf) AND pfxm_prefix pf = 0)"
  unfolding valid_prefix_def .
private lemma valid_prefix_alt: fixes p::"'a::len prefix_match"
  shows "valid_prefix p = (pfxm_prefix p AND (2 ^ ((len_of TYPE ('a)) - pfxm_length p) - 1) = 0)"
  unfolding valid_prefix_def
  unfolding mask_def
  using word_bw_comms(1)
   arg_cong[where f = "\<lambda>x. (pfxm_prefix p AND x - 1 = 0)"]
   shiftl_1
  unfolding pfxm_prefix_def pfxm_mask_def mask_def
  by metis

subsection\<open>Address Semantics\<close>
  text\<open>Matching on a @{typ "'a::len prefix_match"}. Think of routing tables.\<close>
  definition prefix_match_semantics where
    "prefix_match_semantics m a \<equiv> pfxm_prefix m = NOT (pfxm_mask m) AND a"

lemma same_length_prefixes_distinct: "valid_prefix pfx1 \<Longrightarrow> valid_prefix pfx2 \<Longrightarrow> pfx1 \<noteq> pfx2 \<Longrightarrow> pfxm_length pfx1 = pfxm_length pfx2 \<Longrightarrow> prefix_match_semantics pfx1 w \<Longrightarrow> prefix_match_semantics pfx2 w \<Longrightarrow> False"
  by (simp add: pfxm_mask_def prefix_match.expand prefix_match_semantics_def)

subsection\<open>Relation between prefix and set\<close>

  definition prefix_to_wordset :: "'a::len prefix_match \<Rightarrow> 'a word set" where
    "prefix_to_wordset pfx = {pfxm_prefix pfx .. pfxm_prefix pfx OR pfxm_mask pfx}"

  private lemma pfx_not_empty: "valid_prefix pfx \<Longrightarrow> prefix_to_wordset pfx \<noteq> {}"
    unfolding valid_prefix_def prefix_to_wordset_def by(simp add: le_word_or2)

  lemma zero_prefix_match_all:
    "valid_prefix m \<Longrightarrow> pfxm_length m = 0 \<Longrightarrow> prefix_match_semantics m ip"
    by(simp add: pfxm_mask_def mask_2pm1 valid_prefix_alt prefix_match_semantics_def)

  lemma prefix_to_wordset_subset_ipset_from_cidr:
      "prefix_to_wordset pfx \<subseteq> ipset_from_cidr (pfxm_prefix pfx) (pfxm_length pfx)"
    apply(rule subsetI)
    apply(simp add: prefix_to_wordset_def addr_in_ipset_from_cidr_code)
    apply(intro impI conjI)
     apply (metis (erased, hide_lams) order_trans word_and_le2)
    apply(simp add: pfxm_mask_def)
    done

subsection\<open>Equivalence Proofs\<close>
  theorem prefix_match_semantics_wordset:
    assumes "valid_prefix pfx"
    shows "prefix_match_semantics pfx a \<longleftrightarrow> a \<in> prefix_to_wordset pfx"
    using assms
    unfolding valid_prefix_def pfxm_mask_def prefix_match_semantics_def prefix_to_wordset_def
    apply(cases pfx, rename_tac base len)
    apply(simp)
    apply(drule_tac base=base and len=len and a=a in zero_base_lsb_imp_set_eq_as_bit_operation)
    by (simp)

  private lemma valid_prefix_ipset_from_netmask_ipset_from_cidr:
    shows "ipset_from_netmask (pfxm_prefix pfx) (NOT (pfxm_mask pfx)) =
            ipset_from_cidr (pfxm_prefix pfx) (pfxm_length pfx)"
    apply(cases pfx)
    apply(simp add: ipset_from_cidr_alt2 pfxm_mask_def)
   done

  lemma prefix_match_semantics_ipset_from_netmask:
    assumes "valid_prefix pfx"
    shows "prefix_match_semantics pfx a \<longleftrightarrow>
            a \<in> ipset_from_netmask (pfxm_prefix pfx) (NOT (pfxm_mask pfx))"
    unfolding prefix_match_semantics_wordset[OF assms]
    unfolding valid_prefix_ipset_from_netmask_ipset_from_cidr
    unfolding prefix_to_wordset_def
    apply(subst ipset_from_cidr_base_wellforemd)
     subgoal using assms by(simp add: valid_prefix_def pfxm_mask_def)
    by(simp add: pfxm_mask_def)

  lemma prefix_match_semantics_ipset_from_netmask2:
    assumes "valid_prefix pfx"
    shows "prefix_match_semantics pfx (a :: 'i::len word) \<longleftrightarrow>
            a \<in> ipset_from_cidr (pfxm_prefix pfx) (pfxm_length pfx)"
   unfolding prefix_match_semantics_ipset_from_netmask[OF assms] pfxm_mask_def ipset_from_cidr_def
   by (metis (full_types) NOT_mask_shifted_lenword word_not_not)

  lemma prefix_to_wordset_ipset_from_cidr:
    assumes "valid_prefix (pfx::'a::len prefix_match)"
    shows "prefix_to_wordset pfx = ipset_from_cidr (pfxm_prefix pfx) (pfxm_length pfx)"
  proof -
    have helper3: "(x::'a::len word) OR y = x OR y AND NOT x" for x y by (simp add: word_oa_dist2)
    have prefix_match_semantics_ipset_from_netmask:
           "(prefix_to_wordset pfx) = ipset_from_netmask (pfxm_prefix pfx) (NOT (pfxm_mask pfx))"
      unfolding prefix_to_wordset_def ipset_from_netmask_def Let_def
      unfolding word_bool_alg.double_compl
      proof(goal_cases)
        case 1
        have *: "pfxm_prefix pfx AND NOT (pfxm_mask pfx) = pfxm_prefix pfx"
          unfolding mask_eq_0_eq_x[symmetric]
          using valid_prefix_E[OF assms] word_bw_comms(1)[of "pfxm_prefix pfx"] by simp
        hence **: "pfxm_prefix pfx AND NOT (pfxm_mask pfx) OR pfxm_mask pfx =
                    pfxm_prefix pfx OR pfxm_mask pfx"
          by simp
        show ?case unfolding * ** ..
      qed
      have "((mask len)::'a::len word) << LENGTH('a) - len = ~~ (mask (LENGTH('a) - len))"
      for len using NOT_mask_shifted_lenword by (metis word_not_not)
      from this[of "(pfxm_length pfx)"] have mask_def2_symmetric:
        "((mask (pfxm_length pfx)::'a::len word) << LENGTH('a) - pfxm_length pfx) =
          NOT (pfxm_mask pfx)"
        unfolding pfxm_mask_def by simp

      have ipset_from_netmask_prefix:
        "ipset_from_netmask (pfxm_prefix pfx) (NOT (pfxm_mask pfx)) =
          ipset_from_cidr (pfxm_prefix pfx) (pfxm_length pfx)"
       unfolding ipset_from_netmask_def ipset_from_cidr_alt
       unfolding pfxm_mask_def[symmetric]
       unfolding mask_def2_symmetric
       apply(simp)
       unfolding Let_def
       using assms[unfolded valid_prefix_def]
       by (metis helper3 word_bw_comms(2))

      show ?thesis by (metis ipset_from_netmask_prefix local.prefix_match_semantics_ipset_from_netmask)
  qed

  definition prefix_to_wordinterval :: "'a::len prefix_match \<Rightarrow> 'a wordinterval" where
    "prefix_to_wordinterval pfx \<equiv> WordInterval (pfxm_prefix pfx) (pfxm_prefix pfx OR pfxm_mask pfx)"

  lemma prefix_to_wordinterval_set_eq[simp]:
    "wordinterval_to_set (prefix_to_wordinterval pfx) = prefix_to_wordset pfx"
    unfolding prefix_to_wordinterval_def prefix_to_wordset_def by simp

  lemma prefix_to_wordinterval_def2:
    "prefix_to_wordinterval pfx =
      iprange_interval ((pfxm_prefix pfx), (pfxm_prefix pfx OR pfxm_mask pfx))"
    unfolding iprange_interval.simps prefix_to_wordinterval_def by simp
  corollary prefix_to_wordinterval_ipset_from_cidr: "valid_prefix pfx \<Longrightarrow>
    wordinterval_to_set (prefix_to_wordinterval pfx) =
      ipset_from_cidr (pfxm_prefix pfx) (pfxm_length pfx)"
  using prefix_to_wordset_ipset_from_cidr prefix_to_wordinterval_set_eq by auto
end

lemma prefix_never_empty:
  fixes d:: "'a::len prefix_match"
  shows"\<not> wordinterval_empty (prefix_to_wordinterval d)"
by (simp add: le_word_or2 prefix_to_wordinterval_def)

text\<open>Getting a lowest element\<close>
  lemma ipset_from_cidr_lowest: "a \<in> ipset_from_cidr a n"
    using ip_cidr_set_def ipset_from_cidr_eq_ip_cidr_set by blast

  (*this is why I call the previous lemma 'lowest'*)
  lemma "valid_prefix (PrefixMatch a n) \<Longrightarrow> is_lowest_element a (ipset_from_cidr a n)"
    apply(simp add: is_lowest_element_def ipset_from_cidr_lowest)
    apply(simp add: ipset_from_cidr_eq_ip_cidr_set ip_cidr_set_def)
    apply(simp add: valid_prefix_def pfxm_mask_def)
    by (metis diff_zero eq_iff mask_out_sub_mask word_and_le2 word_bw_comms(1))

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Spectral Radius Theory\<close>

text \<open>The following results show that the spectral radius characterize polynomial growth
  of matrix powers.\<close>

theory Spectral_Radius
imports
  Jordan_Normal_Form_Existence
begin

definition "spectrum A = Collect (eigenvalue A)"

lemma spectrum_root_char_poly: assumes A: "(A :: 'a :: field mat) \<in> carrier_mat n n"
  shows "spectrum A = {k. poly (char_poly A) k = 0}"
  unfolding spectrum_def eigenvalue_root_char_poly[OF A, symmetric] by auto

lemma card_finite_spectrum: assumes A: "(A :: 'a :: field mat) \<in> carrier_mat n n"
  shows "finite (spectrum A)" "card (spectrum A) \<le> n"
proof -
  define CP where "CP = char_poly A"
  from spectrum_root_char_poly[OF A] have id: "spectrum A = { k. poly CP k = 0}"
    unfolding CP_def by auto
  from degree_monic_char_poly[OF A] have d: "degree CP = n" and c: "coeff CP n = 1"
    unfolding CP_def by auto
  from c have "CP \<noteq> 0" by auto
  from poly_roots_finite[OF this]
  show "finite (spectrum A)" unfolding id .
  from poly_roots_degree[OF \<open>CP \<noteq> 0\<close>]
  show "card (spectrum A) \<le> n" unfolding id using d by simp
qed

lemma spectrum_non_empty: assumes A: "(A :: complex mat) \<in> carrier_mat n n"
  and n: "n > 0"
  shows "spectrum A \<noteq> {}"
proof -
  define CP where "CP = char_poly A"
  from spectrum_root_char_poly[OF A] have id: "spectrum A = { k. poly CP k = 0}"
    unfolding CP_def by auto
  from degree_monic_char_poly[OF A] have d: "degree CP > 0" using n
    unfolding CP_def by auto
  hence "\<not> constant (poly CP)" by (simp add: constant_degree)
  from fundamental_theorem_of_algebra[OF this] show ?thesis unfolding id by auto
qed

definition spectral_radius :: "complex mat \<Rightarrow> real" where
  "spectral_radius A = Max (norm ` spectrum A)"

text \<open>If spectral radius is at most 1, and JNF exists, then we have polynomial growth.\<close>

lemma spectral_radius_jnf_norm_bound_le_1: assumes A: "A \<in> carrier_mat n n"
  and sr_1: "spectral_radius A \<le> 1"
  and jnf_exists: "\<exists> n_as. jordan_nf A n_as"
  shows "\<exists> c1 c2. \<forall> k. norm_bound (A ^\<^sub>m k) (c1 + c2 * of_nat k ^ (n - 1))"
proof -
  let ?p = "char_poly A"
  from char_poly_factorized[OF A] obtain as where cA: "char_poly A = (\<Prod>a\<leftarrow>as. [:- a, 1:])"
    and len: "length as = n" by auto
  show ?thesis
  proof (rule factored_char_poly_norm_bound[OF A cA jnf_exists])
    fix a
    show "length (filter ((=) a) as) \<le> n" using len by auto
    assume "a \<in> set as"
    from linear_poly_root[OF this]
    have "poly ?p a = 0" unfolding cA by simp
    with spectrum_root_char_poly[OF A]
    have mem: "norm a \<in> norm ` spectrum A" by auto
    with card_finite_spectrum[OF A] have "n > 0" by (cases n, auto)
    from spectral_radius_mem_max(2)[OF A this mem] sr_1
    show "norm a \<le> 1" by auto
  qed
qed

text \<open>If spectral radius is smaller than 1, and JNF exists, then we have a constant bound.\<close>

lemma spectral_radius_jnf_norm_bound_less_1: assumes A: "A \<in> carrier_mat n n"
  and sr_1: "spectral_radius A < 1"
  and jnf_exists: "\<exists> n_as. jordan_nf A n_as"
  shows "\<exists> c. \<forall> k. norm_bound (A ^\<^sub>m k) c"
proof -
  let ?p = "char_poly A"
  from char_poly_factorized[OF A] obtain as where cA: "char_poly A = (\<Prod>a\<leftarrow>as. [:- a, 1:])" by auto
  have "\<exists> c1 c2. \<forall> k. norm_bound (A ^\<^sub>m k) (c1 + c2 * of_nat k ^ (0 - 1))"
  proof (rule factored_char_poly_norm_bound[OF A cA jnf_exists])
    fix a
    assume "a \<in> set as"
    from linear_poly_root[OF this]
    have "poly ?p a = 0" unfolding cA by simp
    with spectrum_root_char_poly[OF A]
    have mem: "norm a \<in> norm ` spectrum A" by auto
    with card_finite_spectrum[OF A] have "n > 0" by (cases n, auto)
    from spectral_radius_mem_max(2)[OF A this mem] sr_1
    have lt: "norm a < 1" by auto
    thus "norm a \<le> 1" by auto
    from lt show "norm a = 1 \<Longrightarrow> length (filter ((=) a) as) \<le> 0" by auto
  qed
  thus ?thesis by auto
qed

text \<open>If spectral radius is larger than 1, than we have exponential growth.\<close>

lemma spectral_radius_gt_1: assumes A: "A \<in> carrier_mat n n"
  and n: "n > 0"
  and sr_1: "spectral_radius A > 1"
  shows "\<exists> v c. v \<in> carrier_vec n \<and> norm c > 1 \<and> v \<noteq> 0\<^sub>v n \<and> A ^\<^sub>m k *\<^sub>v v = c^k \<cdot>\<^sub>v v"
proof -
  from sr_1 spectral_radius_mem_max[OF A n] obtain ev
    where ev: "ev \<in> spectrum A" and gt: "norm ev > 1" by auto
  from ev[unfolded spectrum_def eigenvalue_def[abs_def]]
    obtain v where ev: "eigenvector A v ev" by auto
  from eigenvector_pow[OF A this] this[unfolded eigenvector_def] A gt
  show ?thesis
    by (intro exI[of _ v], intro exI[of _ ev], auto)
qed

text \<open>If spectral radius is at most 1 for a complex matrix, then we have polynomial growth.\<close>

lemma spectral_radius_jnf_norm_bound_le_1_upper_triangular: assumes A: "(A :: complex mat) \<in> carrier_mat n n"
  and sr_1: "spectral_radius A \<le> 1"
  shows "\<exists> c1 c2. \<forall> k. norm_bound (A ^\<^sub>m k) (c1 + c2 * of_nat k ^ (n - 1))"
  by (rule spectral_radius_jnf_norm_bound_le_1[OF A sr_1],
    insert char_poly_factorized[OF A] jordan_nf_exists[OF A], blast)

text \<open>If spectral radius is less than 1 for a complex matrix, then we have a constant bound.\<close>

lemma spectral_radius_jnf_norm_bound_less_1_upper_triangular: assumes A: "(A :: complex mat) \<in> carrier_mat n n"
  and sr_1: "spectral_radius A < 1"
  shows "\<exists> c. \<forall> k. norm_bound (A ^\<^sub>m k) c"
  by (rule spectral_radius_jnf_norm_bound_less_1[OF A sr_1],
    insert char_poly_factorized[OF A] jordan_nf_exists[OF A], blast)

text \<open>And we can also get a quantative approximation via the multiplicity of the eigenvalues.\<close>

lemma spectral_radius_poly_bound: fixes A :: "complex mat"
  assumes A: "A \<in> carrier_mat n n"
  and sr_1: "spectral_radius A \<le> 1"
  and eq_1: "\<And> ev k. poly (char_poly A) ev = 0 \<Longrightarrow> norm ev = 1 \<Longrightarrow> Polynomial.order ev (char_poly A) \<le> d"
  shows "\<exists> c1 c2. \<forall> k. norm_bound (A ^\<^sub>m k) (c1 + c2 * of_nat k ^ (d - 1))"
proof -
  {
    fix ev
    assume "poly (char_poly A) ev = 0"
    with eigenvalue_root_char_poly[OF A] have ev: "eigenvalue A ev" by simp
    hence "norm ev \<in> norm ` spectrum A" unfolding spectrum_def by auto
    from spectral_radius_mem_max(2)[OF A eigenvalue_imp_nonzero_dim[OF A ev] this] sr_1
    have "norm ev \<le> 1" by auto
  } note le_1 = this
  let ?p = "char_poly A"
  from char_poly_factorized[OF A] obtain as where cA: "char_poly A = (\<Prod>a\<leftarrow>as. [:- a, 1:])"
    and lenn: "length as = n" by auto
  from degree_monic_char_poly[OF A] have deg: "degree (char_poly A) = n" by auto
  show ?thesis
  proof (rule factored_char_poly_norm_bound[OF A cA jordan_nf_exists[OF A]], rule cA)
    fix ev
    assume "ev \<in> set as"
    hence root: "poly (char_poly A) ev = 0" unfolding cA by (rule linear_poly_root)
    from le_1[OF root] show "norm ev \<le> 1" .
    let ?k = "length (filter ((=) ev) as)"
    have len: "length (filter ((=) (- ev)) (map uminus as)) = length (filter ((=) ev) as)"
      by (induct as, auto)
    have prod: "(\<Prod>a\<leftarrow>map uminus as. [:a, 1:]) = (\<Prod>a\<leftarrow>as. [:- a, 1:])"
      by (induct as, auto)
    have dvd: "[:- ev, 1:] ^ ?k dvd char_poly A" unfolding cA using
      poly_linear_exp_linear_factors_rev[of "- ev" "map uminus as"]
      unfolding len prod .
    from \<open>ev \<in> set as\<close> deg lenn
    have "degree (char_poly A) \<noteq> 0" by (cases as, auto)
    hence "char_poly A \<noteq> 0" by auto
    from order_max[OF dvd this] have k: "?k \<le> Polynomial.order ev (char_poly A)" .
    assume "norm ev = 1"
    from eq_1[OF root this] k
    show "?k \<le> d" by simp
  qed
qed

end


section \<open>Instantiation of Syntax-Independent Logic Infrastructure\<close>

(*<*)
theory Instance
imports "Syntax_Independent_Logic.Standard_Model" "Syntax_Independent_Logic.Deduction_Q" Robinson_Arithmetic
begin
(*>*)

subsection \<open>Preliminaries\<close>

inductive_set num :: "trm set" where
 zer[intro!,simp]: "zer \<in> num"
|suc[simp]: "t \<in> num \<Longrightarrow> suc t \<in> num"

definition ground_aux :: "trm \<Rightarrow> atom set \<Rightarrow> bool"
  where "ground_aux t S \<equiv> (supp t \<subseteq> S)"

abbreviation ground :: "trm \<Rightarrow> bool"
  where "ground t \<equiv> ground_aux t {}"

definition ground_fmla_aux :: "fmla \<Rightarrow> atom set \<Rightarrow> bool"
  where "ground_fmla_aux A S \<equiv> (supp A \<subseteq> S)"

abbreviation ground_fmla :: "fmla \<Rightarrow> bool"
  where "ground_fmla A \<equiv> ground_fmla_aux A {}"

lemma ground_aux_simps[simp]:
  "ground_aux zer S = True"
  "ground_aux (Var k) S = (if atom k \<in> S then True else False)"
  "ground_aux (suc t) S = (ground_aux t S)"
  "ground_aux (pls t u) S = (ground_aux t S \<and> ground_aux u S)"
  "ground_aux (tms t u) S = (ground_aux t S \<and> ground_aux u S)"
unfolding ground_aux_def
by (simp_all add: supp_at_base)

lemma ground_fmla_aux_simps[simp]:
  "ground_fmla_aux fls S = True"
  "ground_fmla_aux (t EQ u) S = (ground_aux t S \<and> ground_aux u S)"
  "ground_fmla_aux (A OR B) S = (ground_fmla_aux A S \<and> ground_fmla_aux B S)"
  "ground_fmla_aux (A AND B) S = (ground_fmla_aux A S \<and> ground_fmla_aux B S)"
  "ground_fmla_aux (A IFF B) S = (ground_fmla_aux A S \<and> ground_fmla_aux B S)"
  "ground_fmla_aux (neg A) S =  (ground_fmla_aux A S)"
  "ground_fmla_aux (exi x A) S = (ground_fmla_aux A (S \<union> {atom x}))"
by (auto simp: ground_fmla_aux_def ground_aux_def supp_conv_fresh)

lemma ground_fresh[simp]:
  "ground t \<Longrightarrow> atom i \<sharp> t"
  "ground_fmla A \<Longrightarrow> atom i \<sharp> A"
unfolding ground_aux_def ground_fmla_aux_def fresh_def
by simp_all

(* This applies to all nominal types, including terms and formulas: *)
definition "Fvars t = {a :: name. \<not> atom a \<sharp> t}"

lemma Fvars_trm_simps[simp]:
  "Fvars zer = {}"
  "Fvars (Var a) = {a}"
  "Fvars (suc x ) = Fvars x"
  "Fvars (pls x y) = Fvars x \<union> Fvars y"
  "Fvars (tms x y) = Fvars x \<union> Fvars y"
  by (auto simp: Fvars_def fresh_at_base(2))

lemma finite_Fvars_trm[simp]:
  fixes t :: trm
  shows "finite (Fvars t)"
  by (induct t rule: trm.induct) auto

lemma Fvars_fmla_simps[simp]:
  "Fvars (x EQ y) = Fvars x \<union> Fvars y"
  "Fvars (A OR B) = Fvars A \<union> Fvars B"
  "Fvars (A AND B) = Fvars A \<union> Fvars B"
  "Fvars (A IMP B) = Fvars A \<union> Fvars B"
  "Fvars fls = {}"
  "Fvars (neg A) = Fvars A"
  "Fvars (exi a A) = Fvars A - {a}"
  "Fvars (all a A) = Fvars A - {a}"
  by (auto simp: Fvars_def fresh_at_base(2))

lemma finite_Fvars_fmla[simp]:
  fixes A :: fmla
  shows "finite (Fvars A)"
  by (induct A rule: fmla.induct) auto

lemma subst_trm_subst_trm[simp]:
  "x \<noteq> y \<Longrightarrow> atom x \<sharp> u \<Longrightarrow> subst y u (subst x t v) = subst x (subst y u t) (subst y u v)"
  by (induct v rule: trm.induct) auto

lemma subst_fmla_subst_fmla[simp]:
  "x \<noteq> y \<Longrightarrow> atom x \<sharp> u \<Longrightarrow> (A(x::=t))(y::=u) = (A(y::=u))(x::=subst y u t)"
  by (nominal_induct A avoiding: x t y u rule: fmla.strong_induct) auto

lemma Fvars_empty_ground[simp]: "Fvars t = {} \<Longrightarrow> ground t"
  by (induct t rule: trm.induct) auto

lemma Fvars_ground_aux: "Fvars t \<subseteq> B \<Longrightarrow> ground_aux t (atom ` B)"
  by (induct t rule: trm.induct) auto

lemma ground_Fvars: "ground t \<longleftrightarrow> Fvars t = {}"
  apply (rule iffI)
  subgoal by (auto simp only: Fvars_def ground_fresh) []
  by auto

lemma Fvars_ground_fmla_aux: "Fvars A \<subseteq> B \<Longrightarrow> ground_fmla_aux A (atom ` B)"
  apply (induct A arbitrary: B rule: fmla.induct)
  subgoal by (auto simp: Diff_subset_conv Fvars_ground_aux)
  subgoal by (auto simp: Diff_subset_conv Fvars_ground_aux)
  subgoal by (auto simp: Diff_subset_conv Fvars_ground_aux)
  subgoal by (metis Diff_subset_conv Fvars_fmla_simps(7) Un_insert_left
              Un_insert_right ground_fmla_aux_simps(7)
              image_insert sup_bot.left_neutral sup_bot.right_neutral) .

lemma ground_fmla_Fvars: "ground_fmla A \<longleftrightarrow> Fvars A = {}"
  apply (rule iffI)
  subgoal by (auto simp only: Fvars_def ground_fresh)
  by (auto intro: Fvars_ground_fmla_aux[of A "{}", simplified])

lemma obtain_const_trm:
obtains t where "eval_trm e t = x" "t \<in> num"
apply (induct x)
using eval_trm.simps(1) eval_trm.simps(3) num.suc by blast+

lemma ex_eval_fmla_iff_exists_num:
  "eval_fmla e (exi k A) \<longleftrightarrow> (\<exists>t. eval_fmla e (A(k::=t)) \<and> t \<in> num)"
by (auto simp: eval_subst_fmla) (metis obtain_const_trm)

lemma exi_ren: "y \<notin> Fvars \<phi> \<Longrightarrow> exi x \<phi> = exi y (\<phi>(x::=Var y))"
using exi_ren_subst_fresh Fvars_def by blast

lemma all_ren: "y \<notin> Fvars \<phi> \<Longrightarrow> all x \<phi> = all y (\<phi>(x::=Var y))"
by (simp add: exi_ren)

lemma Fvars_num[simp]: "t \<in> num \<Longrightarrow> Fvars t = {}"
by (induct t rule: trm.induct) (auto elim: num.cases)

subsection \<open>Instantiation of the generic syntax and deduction relation\<close>

interpretation Generic_Syntax where
      var = "UNIV :: name set"
  and trm = "UNIV :: trm set"
  and fmla = "UNIV :: fmla set"
  and Var = Var
  and FvarsT = Fvars
  and substT = "\<lambda>t u x. subst x u t"
  and Fvars = Fvars
  and subst = "\<lambda>A u x. subst_fmla A x u"
  apply unfold_locales
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal for t by (induct t rule: trm.induct) auto
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal unfolding Fvars_def fresh_subst_fmla_if by auto
  subgoal unfolding Fvars_def by auto
  subgoal unfolding Fvars_def by simp
  subgoal by simp
  subgoal unfolding Fvars_def by simp .

interpretation Syntax_with_Numerals where
      var = "UNIV :: name set"
  and trm = "UNIV :: trm set"
  and fmla = "UNIV :: fmla set"
  and num = num
  and Var = Var
  and FvarsT = Fvars
  and substT = "\<lambda>t u x. subst x u t"
  and Fvars = Fvars
  and subst = "\<lambda>A u x. subst_fmla A x u"
  apply unfold_locales
  subgoal by (auto intro!: exI[of _ zer])
  subgoal by simp
  subgoal by (simp add: ground_Fvars) .

interpretation Deduct_with_False where
      var = "UNIV :: name set"
  and trm = "UNIV :: trm set"
  and fmla = "UNIV :: fmla set"
  and num = num
  and Var = Var
  and FvarsT = Fvars
  and substT = "\<lambda>t u x. subst x u t"
  and Fvars = Fvars
  and subst = "\<lambda>A u x. subst_fmla A x u"
  and eql = eql and cnj = cnj and imp = imp and all = all
  and exi = exi and fls = fls
  and prv = "(\<turnstile>) {}"
  apply unfold_locales
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal unfolding Fvars_def by simp
  subgoal unfolding Fvars_def by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal using MP_null by blast
  subgoal by blast
  subgoal for A B C
    apply (rule imp_I)+
    apply (rule MP_same[of _ B])
     apply (rule MP_same[of _ C])
      apply (auto intro: neg_D) .
  subgoal by blast
  subgoal by blast
  subgoal by blast
  subgoal unfolding Fvars_def by (auto intro: MP_null)
  subgoal unfolding Fvars_def by (auto intro: MP_null)
  subgoal by (auto intro: all_D)
  subgoal by (auto intro: exi_I)
  subgoal by simp
  subgoal by (metis cnj_E2 Iff_def imp_I Var_eql_subst_Iff)
  subgoal by blast .

interpretation Deduct_with_False_Disj where
      var = "UNIV :: name set"
  and trm = "UNIV :: trm set"
  and fmla = "UNIV :: fmla set"
  and num = num
  and Var = Var
  and FvarsT = Fvars
  and substT = "\<lambda>t u x. subst x u t"
  and Fvars = Fvars
  and subst = "\<lambda>A u x. subst_fmla A x u"
  and eql = eql and cnj = cnj and dsj = dsj and imp = imp
  and all = all and exi = exi and fls = fls
  and prv = "(\<turnstile>) {}"
  apply unfold_locales
  subgoal by simp
  subgoal by simp
  subgoal by simp
  subgoal by (auto intro: dsj_I1)
  subgoal by (auto intro: dsj_I2)
  subgoal by (auto intro: ContraAssume) .

subsection \<open>Instantiation of the arithmetic-enriched generic syntax and deduction relation\<close>

interpretation Syntax_Arith_aux where
      var = "UNIV :: name set"
  and trm = "UNIV :: trm set"
  and fmla = "UNIV :: fmla set"
  and num = num
  and Var = Var
  and FvarsT = Fvars
  and substT = "\<lambda>t u x. subst x u t"
  and Fvars = Fvars
  and subst = "\<lambda>A u x. subst_fmla A x u"
  and eql = eql and cnj = cnj and imp = imp and all = all
  and exi = exi and dsj = dsj and fls = fls
  and zer = zer and suc = suc and pls = pls and tms = tms
  by unfold_locales (auto simp: exi_ren all_ren)

lemma num_range_Num: "num = range Num"
proof-
  {fix t assume "t \<in> num"
   then have "\<exists>n. t = Num n"
   apply(induct t rule: trm.induct)
   subgoal by (auto intro: exI[of _ 0])
   subgoal by (auto elim: num.cases)
   subgoal by (metis Num.simps(2) num.cases trm.distinct(3) trm.eq_iff(3))
   by (auto elim: num.cases)
  }
  moreover
  {fix n have "Num n \<in> num"
   by (induct n) auto
  }
  ultimately show ?thesis by auto
qed

lemma [simp]: "{} \<turnstile> Var yy EQ zer OR exi xx (Var yy EQ suc (Var xx))"
by (intro nprv.Q) (auto intro!: exI[of _ zz] simp: Q_axioms_def)

lemma [simp]: "{} \<turnstile> pls (Var xx) zer EQ Var xx"
by (intro nprv.Q) (auto intro!: exI[of _ zz] simp: Q_axioms_def)

lemma [simp]: "{} \<turnstile> tms (Var xx) zer EQ zer"
by (intro nprv.Q) (auto intro!: exI[of _ zz] simp: Q_axioms_def)

interpretation S: Syntax_Arith where
      var = "UNIV :: name set"
  and trm = "UNIV :: trm set"
  and fmla = "UNIV :: fmla set"
  and num = num
  and Var = Var
  and FvarsT = Fvars
  and substT = "\<lambda>t u x. subst x u t"
  and Fvars = Fvars
  and subst = "\<lambda>A u x. subst_fmla A x u"
  and eql = eql and cnj = cnj and imp = imp and all = all
  and exi = exi and dsj = dsj and fls = fls and zer = zer
  and suc = suc and pls = pls and tms = tms
  using num_range_Num by unfold_locales auto

interpretation Deduct_Q where
      var = "UNIV :: name set"
  and trm = "UNIV :: trm set"
  and fmla = "UNIV :: fmla set"
  and num = num
  and Var = Var
  and FvarsT = Fvars
  and substT = "\<lambda>t u x. subst x u t"
  and Fvars = Fvars
  and subst = "\<lambda>A u x. subst_fmla A x u"
  and eql = eql and cnj = cnj and imp = imp and all = all
  and exi = exi and dsj = dsj and fls = fls and zer = zer
  and suc = suc and pls = pls and tms = tms
  and prv = "(\<turnstile>) {}"
  by unfold_locales (auto simp add: Q Q_axioms_def)

subsection \<open>Instantiation of the abstract notion of standard model and truth\<close>

interpretation Minimal_Truth_Soundness where
      var = "UNIV :: name set"
  and trm = "UNIV :: trm set"
  and fmla = "UNIV :: fmla set"
  and num = num
  and Var = Var
  and FvarsT = Fvars
  and substT = "\<lambda>t u x. subst x u t"
  and Fvars = Fvars
  and subst = "\<lambda>A u x. subst_fmla A x u"
  and eql = eql and cnj = cnj and dsj = dsj and imp = imp
  and all = all and exi = exi and fls = fls
  and prv = "(\<turnstile>) {}"
  and isTrue = "eval_fmla e0"
  apply unfold_locales
  subgoal by (auto simp: fls_def)
  subgoal by simp
  subgoal by (auto simp only: ex_eval_fmla_iff_exists_num eval_fmla.simps  subst_fmla.simps)
  subgoal by (auto simp only: ex_eval_fmla_iff_exists_num)
  subgoal by (simp add: neg_def)
  subgoal by (auto dest: nprv_sound) .

(*<*)
end
(*>*)


section \<open>General purpose definitions and lemmas\<close>

theory JHelper imports
  Main
begin

lemma Collect_iff:
  "a \<in> {x . P x} \<equiv> P a"
by auto

lemma diff_diff_eq:
  assumes "C \<subseteq> B"
  shows "(A - C) - (B - C) = A - B"
using assms by auto

lemma nth_in_set:
  "\<lbrakk> i < length xs ; xs ! i = x \<rbrakk> \<Longrightarrow> x \<in> set xs" by auto

lemma disjI [intro]:
  assumes "\<not> P \<Longrightarrow> Q"
  shows "P \<or> Q"
using assms by auto

lemma empty_eq_Plus_conv:
  "({} = A <+> B) = (A = {} \<and> B = {})"
by auto

subsection \<open>Projection functions on triples\<close>

definition fst3 :: "'a \<times> 'b \<times> 'c \<Rightarrow> 'a"
where "fst3 \<equiv> fst"

definition snd3 :: "'a \<times> 'b \<times> 'c \<Rightarrow> 'b"
where "snd3 \<equiv> fst \<circ> snd"

definition thd3 :: "'a \<times> 'b \<times> 'c \<Rightarrow> 'c"
where "thd3 \<equiv> snd \<circ> snd"

lemma fst3_simp:
  "\<And>a b c. fst3 (a,b,c) = a"
by (auto simp add: fst3_def)

lemma snd3_simp:
  "\<And>a b c. snd3 (a,b,c) = b"
by (auto simp add: snd3_def)

lemma thd3_simp:
  "\<And>a b c. thd3 (a,b,c) = c"
by (auto simp add: thd3_def)

lemma tripleI:
  fixes T U
  assumes "fst3 T = fst3 U"
      and "snd3 T = snd3 U"
      and "thd3 T = thd3 U"
  shows "T = U"
by (metis assms fst3_def snd3_def thd3_def o_def surjective_pairing)

end


theory
  NREST_Auxiliaries
imports
  "HOL-Library.Extended_Nat" "Automatic_Refinement.Automatic_Refinement"
  "HOL-Library.Lattice_Syntax"
begin

section "Auxiliaries"

subsection "Auxiliaries for option"

lemma less_eq_option_None_is_None': "x \<le> None \<longleftrightarrow> x = None"
  by(auto simp: less_eq_option_None_is_None)

lemma everywhereNone: "(\<forall>x\<in>X. x = None) \<longleftrightarrow> X = {} \<or> X = {None}"
  by auto

subsection "Auxiliaries for enat"

lemma enat_minus_mono: "a' \<ge> b \<Longrightarrow> a' \<ge> a \<Longrightarrow> a' - b \<ge> (a::enat) - b"
  apply(cases a; cases b; cases a') by auto

lemma enat_plus_minus_aux1: "a + b \<le> a' \<Longrightarrow> \<not> a' < a \<Longrightarrow> b \<le> a' - (a::enat)"
  apply(cases a; cases b; cases a') by auto

lemma enat_plus_minus_aux2: "\<not> a < a' \<Longrightarrow> b \<le> a - a' \<Longrightarrow> a' + b \<le> (a::enat)"
  apply(cases a; cases b; cases a') by auto

lemma enat_minus_inf_conv[simp]: "a - enat n = \<infinity> \<longleftrightarrow> a=\<infinity>" by (cases a) auto
lemma enat_minus_fin_conv[simp]: "a - enat n = enat m \<longleftrightarrow> (\<exists>k. a=enat k \<and> m = k - n)"
  by (cases a) auto

lemma helper: "x2 \<le> x2a \<Longrightarrow> \<not> x2 < a \<Longrightarrow> \<not> x2a < a \<Longrightarrow>  x2 - (a::enat) \<le> x2a - a"
  apply(cases x2; cases x2a) apply auto apply(cases a) by auto

lemma helper2: "x2b \<le> x2 \<Longrightarrow> \<not> x2a < x2  \<Longrightarrow> \<not> x2a < x2b \<Longrightarrow> x2a - (x2::enat) \<le> x2a - x2b"
  apply(cases x2; cases x2a) apply auto apply(cases x2b) by auto

lemma Sup_finite_enat: "Sup X = Some (enat a) \<Longrightarrow> Some (enat a) \<in> X"
  by (auto simp: Sup_option_def Sup_enat_def these_empty_eq Max_eq_iff in_these_eq split: if_splits)

lemma Sup_enat_less2: " Sup X = \<infinity> \<Longrightarrow> (\<exists>x\<in>X. enat t < x)"
  unfolding  Sup_enat_def using    finite_enat_bounded linear
  apply(auto split: if_splits)
   apply (smt Max_in empty_iff enat_ord_code(4))
  by (smt not_less)

subsection "Auxiliary (for Sup and Inf)"

lemma aux11: "f`X={y} \<longleftrightarrow> (X\<noteq>{} \<and> (\<forall>x\<in>X. f x = y))" by auto

lemma aux2: "(\<lambda>f. f x) ` {[x \<mapsto> t1] |x t1. M x = Some t1} = {None} \<longleftrightarrow> (M x = None \<and> M\<noteq>Map.empty)"
  apply (cases "M x"; auto simp: aux11)
  by force

lemma aux3: "(\<lambda>f. f x) ` {[x \<mapsto> t1] |x t1. M x = Some t1}
  = {Some t1 | t1. M x = Some t1} \<union> ({None | y. y\<noteq>x \<and> M y \<noteq> None })"
  by (fastforce split: if_splits simp: image_iff)

lemma Sup_pointwise_eq_fun: "(\<Squnion>f \<in> {[x \<mapsto> t1] |x t1. M x = Some t1}. f x) = M x"
  unfolding Sup_option_def
  apply (simp add: aux2)
  apply (auto simp: aux3)
  by (metis (mono_tags, lifting) Some_image_these_eq Sup_least in_these_eq mem_Collect_eq
        sup_absorb1 these_image_Some_eq)

lemma SUP_eq_None_iff: "(\<Squnion>f \<in> X. f x) = None \<longleftrightarrow> X={} \<or> (\<forall>f\<in>X. f x = None)"
  by (smt SUP_bot_conv(2) SUP_empty Sup_empty empty_Sup)

lemma SUP_eq_Some_iff:
  "(\<Squnion>f \<in> X. f x) = Some t \<longleftrightarrow> (\<exists>f\<in>X. f x \<noteq> None) \<and> (t=Sup {t' | f t'. f\<in>X \<and> f x = Some t' })"
  apply auto
  subgoal
    by (smt Sup_bot_conv(1) Sup_empty Sup_option_def Sup_pointwise_eq_fun imageE option.distinct(1))
  subgoal
    unfolding Sup_option_def
    apply (clarsimp split: if_splits)
    apply (fo_rule arg_cong)
    apply (auto simp: Option.these_def)
    apply (metis (mono_tags, lifting) image_iff mem_Collect_eq option.sel)
    apply (metis (mono_tags, lifting) image_iff mem_Collect_eq option.sel)
    done
  subgoal
    unfolding Sup_option_def
    apply (clarsimp split: if_splits; safe)
    subgoal by (force simp: image_iff)
    apply (fo_rule arg_cong)
    apply (auto simp: Option.these_def)
    apply (metis (mono_tags, lifting) image_iff mem_Collect_eq option.sel)
    done
  done

lemma Sup_enat_less: "X \<noteq> {} \<Longrightarrow> enat t \<le> Sup X \<longleftrightarrow> (\<exists>x\<in>X. enat t \<le> x)"
  apply rule
  subgoal
  by (metis Max_in Sup_enat_def finite_enat_bounded linear)
  subgoal apply auto
    by (simp add: Sup_upper2)
  done

(*
  This is how implication can be phrased with an Inf operation.
  Generalization from boolean to enat can be explained this way.
 *)

lemma fixes Q P  shows
    "Inf { P x \<le> Q x |x. True}  \<longleftrightarrow> P \<le> Q" unfolding le_fun_def by simp

end


(*  Title:      HOL/Examples/Seq.thy
    Author:     Makarius
*)

section \<open>Finite sequences\<close>

theory Seq
  imports Main
begin

datatype 'a seq = Empty | Seq 'a "'a seq"

fun conc :: "'a seq \<Rightarrow> 'a seq \<Rightarrow> 'a seq"
where
  "conc Empty ys = ys"
| "conc (Seq x xs) ys = Seq x (conc xs ys)"

fun reverse :: "'a seq \<Rightarrow> 'a seq"
where
  "reverse Empty = Empty"
| "reverse (Seq x xs) = conc (reverse xs) (Seq x Empty)"

lemma conc_empty: "conc xs Empty = xs"
  by (induct xs) simp_all

lemma conc_assoc: "conc (conc xs ys) zs = conc xs (conc ys zs)"
  by (induct xs) simp_all

lemma reverse_conc: "reverse (conc xs ys) = conc (reverse ys) (reverse xs)"
  by (induct xs) (simp_all add: conc_empty conc_assoc)

lemma reverse_reverse: "reverse (reverse xs) = xs"
  by (induct xs) (simp_all add: reverse_conc)

end


section "A Language of Integer Arithmetic and Variables"

theory IntArithVars
  imports Main "~~/src/HOL/Library/FSet"
begin

type_synonym index = nat

datatype exp = EInt int | ERead | EPrim "int\<Rightarrow>int\<Rightarrow>int" exp exp | EVar index | ELet exp exp

type_synonym input = "int list"

type_synonym val = int
type_synonym env = "val list"

fun E :: "exp \<Rightarrow> env \<Rightarrow> input \<Rightarrow> (val \<times> input) option" where
  "E (EInt n) \<rho> i = Some (n,i)" |
  "E (ERead) \<rho> i = (case i of [] \<Rightarrow> None
                        | Cons n i' \<Rightarrow> Some (n, i'))" |
  "E (EPrim f e1 e2) \<rho> i =
     (case E e1 \<rho> i of None \<Rightarrow> None
      | Some (n1,i') \<Rightarrow>
        (case E e2 \<rho> i' of
          None \<Rightarrow> None
        | Some (n2, i'') \<Rightarrow> Some (f n1 n2, i'')))" |
  "E (EVar n) \<rho> i = (if n < length \<rho> then Some (\<rho>!n,i) else None)" |
  "E (ELet e1 e2) \<rho> i =
     (case E e1 \<rho> i of None \<Rightarrow> None
      | Some (n,i') \<Rightarrow> E e2 (n#\<rho>) i')"

fun shifte :: "nat \<Rightarrow> nat \<Rightarrow> exp \<Rightarrow> exp" where
  "shifte k c (EInt n) = (EInt n)" |
  "shifte k c (ERead) = (ERead)" |
  "shifte k c (EPrim f e1 e2) = EPrim f (shifte k c e1) (shifte k c e2)" |
  "shifte k c (EVar n) = (if c \<le> n then EVar (n + k) else EVar n)" |
  "shifte k c (ELet e1 e2) = ELet (shifte k c e1) (shifte k (Suc c) e2)"

section "Intermediate Language in A-normal form"

datatype atom = AInt int | AVar index
datatype fexp = Atom atom | FPrim "int\<Rightarrow>int\<Rightarrow>int" atom atom
datatype stmt = Push fexp | Read
type_synonym block = "stmt list \<times> atom"

fun A :: "atom \<Rightarrow> env \<Rightarrow> int option" where
  "A (AInt n) \<rho> = Some n" |
  "A (AVar k) \<rho> = (if k < length \<rho> then Some (\<rho>!k) else None)"

fun F :: "fexp \<Rightarrow> env \<Rightarrow> int option" where
  "F (Atom a) \<rho> = A a \<rho>" |
  "F (FPrim f e1 e2) \<rho> =
     (case A e1 \<rho> of None \<Rightarrow> None
      | Some n1 \<Rightarrow>
        (case A e2 \<rho> of
          None \<Rightarrow> None
        | Some n2 \<Rightarrow> Some (f n1 n2)))"

type_synonym state = "env \<times> input"
type_synonym state_xfr = "state \<Rightarrow> state option"

fun S :: "stmt \<Rightarrow> state_xfr" where
  "S (Push e) (\<rho>, i) =
     (case F e \<rho> of None \<Rightarrow> None
      | Some n \<Rightarrow> Some (n#\<rho>, i))" |
  "S (Read) (\<rho>, i) = (case i of [] \<Rightarrow> None
                     | Cons n i' \<Rightarrow> Some (n#\<rho>, i'))"

definition seq :: "('a \<Rightarrow> 'b option) \<Rightarrow> ('b \<Rightarrow> 'c option) \<Rightarrow> 'a \<Rightarrow> 'c option" where
  "seq f1 f2 \<sigma> \<equiv> (case f1 \<sigma> of None \<Rightarrow> None | Some \<sigma>' \<Rightarrow> f2 \<sigma>')"

definition ret :: "state_xfr" where
  "ret \<sigma> = Some \<sigma>"

fun Ss :: "stmt list \<Rightarrow> state_xfr" where
  "Ss [] = ret" |
  "Ss (s#ss) = seq (S s) (Ss ss)"

fun As :: "atom \<Rightarrow> state \<Rightarrow> (int \<times> input) option" where
  "As e (\<rho>,i) = (case A e \<rho> of None \<Rightarrow> None | Some n \<Rightarrow> Some (n,i))"

fun B :: "block \<Rightarrow> state \<Rightarrow> (int \<times> input) option" where
  "B (ss,e) = seq (Ss ss) (As e)"

fun shifta :: "nat \<Rightarrow> nat \<Rightarrow> atom \<Rightarrow> atom" where
  "shifta k c (AInt n) = (AInt n)" |
  "shifta k c (AVar n) = (if c \<le> n then AVar (n + k) else AVar n)"

fun shiftf :: "nat \<Rightarrow> nat \<Rightarrow> fexp \<Rightarrow> fexp" where
  "shiftf k c (Atom a) = Atom (shifta k c a)" |
  "shiftf k c (FPrim f e1 e2) = FPrim f (shifta k c e1) (shifta k c e2)"

fun shifts :: "nat \<Rightarrow> nat \<Rightarrow> stmt \<Rightarrow> stmt" where
  "shifts k c (Read) = Read" |
  "shifts k c (Push e) = Push (shiftf k c e)"

fun shiftss :: "nat \<Rightarrow> nat \<Rightarrow> stmt list \<Rightarrow> stmt list" where
  "shiftss k c [] = []" |
  "shiftss k c (s#ss) = (let ss' = shiftss k (Suc c) ss in (shifts k c s)#ss')"

(*
fun shiftb :: "nat \<Rightarrow> nat \<Rightarrow> block \<Rightarrow> block" where
  "shiftb k c ([], e) = ([], shifta k c e)" |
  "shiftb k c (s#ss, e) = (let (ss',e') = shiftb k (Suc c) (ss,e)
                           in ((shifts k c s)#ss', e'))"
*)
fun shiftb :: "nat \<Rightarrow> nat \<Rightarrow> block \<Rightarrow> block" where
  "shiftb k c (ss,e) = (let ss' = shiftss k c ss in (ss', shifta k (c + length ss) e))"

lemma seq_ret[simp]: "seq ret f = f"
  unfolding seq_def ret_def apply (rule ext) apply auto done

lemma seq_assoc: "seq (seq f1 f2) f3 = seq f1 (seq f2 f3)"
  unfolding seq_def apply (rule ext) apply (case_tac "f1 \<sigma>") apply auto done

lemma Ss_append_seq[simp]: "Ss (ss1@ss2) = seq (Ss ss1) (Ss ss2)"
  by (induction ss1) (auto simp: seq_assoc)

lemma seq1_none[simp]: "f1 \<sigma> = None \<Longrightarrow> seq f1 f2 \<sigma> = None"
  by (simp add: seq_def)

lemma seq1_some[simp]: "f1 \<sigma> = Some \<sigma>' \<Longrightarrow> seq f1 f2 \<sigma> = f2 \<sigma>'"
  by (simp add: seq_def)

lemma seq_front: "f1 \<sigma> = f1' \<sigma>' \<Longrightarrow> seq f1 f2 \<sigma> = seq f1' f2 \<sigma>'"
  by (simp add: seq_def)

section "Compilation Pass: Flattening"

fun flatten :: "exp \<Rightarrow> block" where
  "flatten (EInt n) = ([], AInt n)" |
  "flatten (ERead) = ([Read], AVar 0)" |
  "flatten (EPrim f e1 e2) =
    (let (ss1,a1) = flatten e1 in
     let (ss2,a2) = flatten e2 in
     let a1' = shifta (length ss2) 0 a1 in
     let (ss2',a2') = shiftb (length ss1) 0 (ss2,a2) in
     (ss1 @ ss2' @ [Push (FPrim f a1' a2')], AVar 0))" |
  "flatten (EVar x) = ([], AVar x)" |
  "flatten (ELet e1 e2) =
    (let (ss1,a1) = flatten e1 in
     let (ss2,a2) = flatten e2 in
     let (ss2',a2') = shiftb (length ss1) 1 (ss2,a2) in
     (ss1 @ (Push (Atom a1)) # ss2', a2'))"

fun flatten_program :: "exp \<Rightarrow> block" where
  "flatten_program e = (let (ss,e') = flatten e in (ss, e'))"

fun eadd :: "exp \<Rightarrow> exp \<Rightarrow> exp" where
  "eadd e1 e2 = EPrim (\<lambda>a.\<lambda>b. a+b) e1 e2"
fun esub :: "exp \<Rightarrow> exp \<Rightarrow> exp" where
  "esub e1 e2 = EPrim (\<lambda>a.\<lambda>b. a-b) e1 e2"

section "A Little Testing"

(*  (4 + 40) - (7 - 5) = 42*)
definition P0 :: exp where
  "P0 \<equiv> esub (eadd (EInt 4) (EInt 40)) (esub (EInt 7) (EInt 5))"

value "E P0 [] []"
value "flatten_program P0"
value "B (flatten_program P0) ([],[])"

definition P1 :: exp where
  "P1 \<equiv> ELet P0 (eadd (esub (EInt 2) (EInt 2)) (EVar 0))"

value "E P1 [] []"
value "flatten_program P1"
value "B (flatten_program P1) ([],[])"

section "Lemmas regarding shift"

lemma nth_append1[simp]: "n < length \<rho>1 \<Longrightarrow> (\<rho>1@\<rho>2)!n = \<rho>1!n"
  apply (induction \<rho>1 arbitrary: \<rho>2 n)
  apply force
  apply (case_tac n) apply simp apply simp done

lemma nth_append2[simp]: "n \<ge> length \<rho>1 \<Longrightarrow> (\<rho>1@\<rho>2)!n = \<rho>2!(n - length \<rho>1)"
  apply (induction \<rho>1 arbitrary: \<rho>2 n)
  apply force
  apply (case_tac n) apply simp apply simp done

lemma shifta_append: "A e (\<rho>1@\<rho>3) = A (shifta (length \<rho>2) (length \<rho>1) e) (\<rho>1@\<rho>2@\<rho>3)"
  by (cases e) auto

lemma shiftas_append: "As a (\<rho>1@\<rho>3,i) = As (shifta (length \<rho>2) (length \<rho>1) a) (\<rho>1@\<rho>2@\<rho>3,i)"
  apply simp apply (case_tac "A a (\<rho>1@\<rho>3)") using shifta_append apply auto done

lemma shiftf_append: "F e (\<rho>1@\<rho>3) = F (shiftf (length \<rho>2) (length \<rho>1) e) (\<rho>1@\<rho>2@\<rho>3)"
  apply (cases e)
  using shifta_append apply force
  apply simp apply (case_tac "A x22 (\<rho>1@\<rho>3)") apply auto using shifta_append apply auto
  done

lemma Ss_result: "S s (\<rho>,i) = None \<or> (\<exists> v i'. S s (\<rho>,i) = Some (v#\<rho>,i'))"
  apply (cases s) apply simp apply (case_tac "F x1 \<rho>") apply auto
  apply (case_tac i) apply auto
  done

lemma Sss_result: "Ss ss (\<rho>,i) = None \<or> (\<exists> \<rho>' i'. Ss ss (\<rho>,i) = Some (\<rho>'@\<rho>,i') \<and> length \<rho>' = length ss)"
  apply (induction ss arbitrary: \<rho> i)
  apply (force simp: ret_def)
  apply (subgoal_tac "S a (\<rho>,i) = None \<or> (\<exists> v i'. S a (\<rho>,i) = Some (v#\<rho>,i'))")
    prefer 2 apply (rule Ss_result)
  apply (erule disjE) apply force
  apply (erule exE)+
  apply (subgoal_tac " Ss ss (v#\<rho>, i') = None \<or>
             (\<exists>\<rho>' i''. Ss ss (v#\<rho>, i') = Some (\<rho>' @ (v#\<rho>), i'') \<and> length \<rho>' = length ss)")
    prefer 2 apply blast
    apply (erule disjE) apply force
    apply (rule disjI2) apply force
  done

lemma shifts_append_some: "S s (\<rho>1@\<rho>3,i) = Some (v#(\<rho>1@\<rho>3),i') \<Longrightarrow>
    S (shifts (length \<rho>2) (length \<rho>1) s) (\<rho>1@\<rho>2@\<rho>3,i) = Some (v#(\<rho>1@\<rho>2@\<rho>3),i')"
  apply (cases s)
  -- "Push x1"
  apply simp apply (case_tac "F x1 (\<rho>1@\<rho>3)")
    using shiftf_append apply force
    apply simp apply (subgoal_tac "F x1 (\<rho>1@\<rho>3) = F (shiftf (length \<rho>2) (length \<rho>1) x1) (\<rho>1@\<rho>2@\<rho>3)")
    prefer 2 using shiftf_append apply blast
    apply simp
  -- "Read"
  apply simp apply (case_tac i) apply auto
  done

lemma shifts_append_none: "S s (\<rho>1@\<rho>3,i) = None \<Longrightarrow>
   S (shifts (length \<rho>2) (length \<rho>1) s) (\<rho>1@\<rho>2@\<rho>3,i) = None"
  apply (cases s)
  apply simp apply (case_tac "F x1 (\<rho>1@\<rho>3)")
    using shiftf_append apply force
    using shiftf_append apply force
  apply simp apply (case_tac i) apply auto
  done

lemma shiftss_append_some: assumes Ss_ss: "Ss ss (\<rho>1@\<rho>3,i) = Some (\<rho>@\<rho>1@\<rho>3, i')"
  shows "Ss (shiftss (length \<rho>2) (length \<rho>1) ss) (\<rho>1@\<rho>2@\<rho>3,i) = Some (\<rho>@\<rho>1@\<rho>2@\<rho>3,i')"
  using Ss_ss
proof (induction ss arbitrary: \<rho> \<rho>1 \<rho>2 \<rho>3 i i')
  case Nil
  then show ?case by (simp add: ret_def)
next
  case (Cons s ss)
  show ?case
  proof (cases "S s (\<rho>1@\<rho>3,i)")
    case None
    from Cons None show ?thesis using shifts_append_none by auto
  next
    case (Some a)
    let ?s0 = "(\<rho>1@\<rho>3,i)"
    from Some obtain v i1 where S_s: "S s (\<rho>1@\<rho>3,i) = Some (v#\<rho>1@\<rho>3, i1)"
      using Ss_result[of s "\<rho>1@\<rho>3" i] by auto
    let ?s1 = "(v#\<rho>1@\<rho>3, i1)"
    let ?s2 = "(\<rho>@\<rho>1@\<rho>3,i')"
    from Cons(2) S_s obtain \<rho>0 where S_ss: "Ss ss ?s1 = Some ?s2"
      and r: "\<rho>=\<rho>0@[v]" using Sss_result[of ss "v#\<rho>1@\<rho>3" i1] by auto

    let ?sp = "shifts (length \<rho>2) (length \<rho>1) s" and ?ssp = "(shiftss (length \<rho>2)(length(v#\<rho>1)) ss)"
    let ?s0p = "(\<rho>1@\<rho>2@\<rho>3, i)" and ?s1p = "(v#\<rho>1@\<rho>2@\<rho>3,i1)" and ?s2p = "(\<rho>@\<rho>1@\<rho>2@\<rho>3,i')"

    from S_s have S_sp: "S ?sp ?s0p = Some ?s1p" using shifts_append_some by auto
    from S_ss r have "Ss ss ((v # \<rho>1) @ \<rho>3, i1) = Some (\<rho>0 @ (v # \<rho>1) @ \<rho>3, i')" by simp
    from this r Cons(1)[of "v#\<rho>1" \<rho>3 i1 \<rho>0 i' \<rho>2] have S_ssp: "Ss ?ssp ?s1p = Some ?s2p" by simp
    from S_sp S_ssp r show ?thesis by simp
  qed
qed

(*
lemma shiftb_append: "B (ss,e) (\<rho>1@\<rho>3,i) = B (shiftb (length \<rho>2) (length \<rho>1) (ss,e)) (\<rho>1@\<rho>2@\<rho>3,i)"
  apply (induction ss arbitrary: \<rho>1 \<rho>2 \<rho>3 i e)
  using shifta_append apply force
proof -
  fix s ss and \<rho>1::env and \<rho>2::env and \<rho>3::env and i e
  assume IH: "\<And>\<rho>1 \<rho>2 \<rho>3 i e. B (ss, e) (\<rho>1@\<rho>3, i) = B (shiftb (length \<rho>2) (length \<rho>1) (ss, e))
            (\<rho>1@\<rho>2@\<rho>3, i)"
  let ?sp = "shifts (length \<rho>2) (length \<rho>1) s"
  show "B (s # ss, e) (\<rho>1 @ \<rho>3, i) = B (shiftb (length \<rho>2) (length \<rho>1) (s # ss, e)) (\<rho>1@\<rho>2@\<rho>3, i)"
  proof (cases "S s (\<rho>1@\<rho>3,i)")
    case None
    from None have s_sp: "S ?sp (\<rho>1@\<rho>2@\<rho>3,i) = None" using shifts_append_none by blast
    from None s_sp
    show ?thesis apply simp apply (case_tac "shiftb (length \<rho>2) (Suc (length \<rho>1)) (ss, e)") by auto
  next
    case (Some \<sigma>)
    from Some obtain v i' where s: "\<sigma> = (v#(\<rho>1@\<rho>3), i')" using Ss_result[of s "\<rho>1@\<rho>3" i] by auto
    from Some s have s_sp: "S ?sp (\<rho>1@\<rho>2@\<rho>3,i) = Some (v#(\<rho>1@\<rho>2@\<rho>3),i')"
      using shifts_append_some[of s \<rho>1 \<rho>3] by auto
    from IH[of e "v#\<rho>1" \<rho>3 i' \<rho>2] s have
      1: "B (ss,e) \<sigma> = B (shiftb(length \<rho>2)(length (v#\<rho>1))(ss,e)) ((v#\<rho>1)@\<rho>2@\<rho>3,i')" by simp
    from s_sp 1 s Some
    show ?thesis apply simp apply (case_tac "shiftb (length \<rho>2) (Suc (length \<rho>1)) (ss, e)")
        by (auto simp: seq_assoc)
  qed
qed
*)

section "Correctness of Flattening"

lemma B_append: assumes 1: "B (ss2, e1) = B (ss2', e2)"
  shows "B (ss1 @ ss2, e1) (\<rho>, i) = B (ss1 @ ss2', e2) (\<rho>, i)"
proof (cases "Ss ss1 (\<rho>,i)")
  case None
  then show ?thesis by simp
next
  case (Some \<sigma>)
  from Some obtain \<rho>' i' where Ss_ss1: "Ss ss1 (\<rho>,i) = Some (\<rho>',i')" by (cases \<sigma>) auto
  from 1 have A: "B (ss2, e1) (\<rho>',i') = B (ss2', e2) (\<rho>',i')" by simp
  from Ss_ss1 A show ?thesis by (simp add: seq_assoc)
qed

lemma flatten_correct: "flatten e = (ss, e') \<Longrightarrow> E e \<rho> i = B (ss, e') (\<rho>, i)"
proof (induction e arbitrary: e' \<rho> i ss)
  case (EInt n)
  have "E (EInt n) \<rho> i = Some (n,i)" by simp
  also have "... = B ([], AInt n) (\<rho>, i)" by simp
  also have "... = B (flatten (EInt n)) (\<rho>,i)" by simp
  also from EInt have "... = B (ss,e') (\<rho>,i)" by simp
  finally show ?case .
next
  case ERead
  have "E ERead \<rho> i = B ([Read], AVar 0) (\<rho>, i)"
    by (cases i) (auto simp: seq_def seq_assoc)
  also have "... = B (flatten ERead) (\<rho>,i)" by simp
  also from ERead have "... = B (ss,e') (\<rho>,i)" by simp
  finally show ?case .
next
  case (EPrim f e1 e2 e' \<rho> i ss)
  obtain ss1 a1 where fe1: "flatten e1 = (ss1,a1)" by (case_tac "flatten e1") simp
  obtain ss2 a2 where fe2: "flatten e2 = (ss2,a2)" by (case_tac "flatten e2") simp
  obtain a1' where a1p: "a1' = shifta (length ss2) 0 a1" by auto
  obtain ss2' where ss2p: "shiftss (length ss1) 0 ss2 = ss2'" by auto
  obtain a2' where a2p: "shifta (length ss1) (length ss2) a2 = a2'" by auto

  from fe1 fe2 a1p ss2p a2p
  have fp: "flatten (EPrim f e1 e2) = (ss1@ss2'@[Push (FPrim f a1' a2')], AVar 0)" by simp

  from EPrim fe1 have IH1: "E e1 \<rho> i = B (ss1,a1) (\<rho>,i)" by simp
  show ?case
  proof (cases "E e1 \<rho> i")
    case None
    from Sss_result[of ss1 \<rho> i] have "Ss ss1 (\<rho>,i) = None \<or> (\<exists> \<rho>' i'. Ss ss1 (\<rho>,i) = Some (\<rho>'@\<rho>,i')
        \<and> length \<rho>' = length ss1)" by simp
    from this show ?thesis
    proof
      assume "Ss ss1 (\<rho>,i) = None"
      from this EPrim(3) None fp show ?thesis apply auto done
    next
      assume "\<exists> \<rho>' i'. Ss ss1 (\<rho>,i) = Some (\<rho>'@\<rho>,i') \<and> length \<rho>' = length ss1"
      from this obtain \<rho>' i' where Ss_ss1: "Ss ss1 (\<rho>,i) = Some (\<rho>'@\<rho>,i')" by blast
      from IH1 Ss_ss1 None have "A a1 (\<rho>'@\<rho>) = None" apply (case_tac "A a1 (\<rho>'@\<rho>)") by auto
      from this Ss_ss1 fp EPrim(3) None fe1 fe2 show ?thesis sorry
    qed
  next
    case (Some r1)
    from Some obtain n1 i' where Ee1: "E e1 \<rho> i = Some (n1,i')" by (cases r1) simp
    let ?s0 = "(\<rho>,i)"
    from IH1 Ee1 Sss_result[of ss1 \<rho> i] obtain \<rho>1 where Ss_ss1: "Ss ss1 (\<rho>,i) = Some (\<rho>1@\<rho>,i')" and
      Aa1: "As a1 (\<rho>1@\<rho>,i') = Some (n1,i')" and lr1_ss1: "length \<rho>1 = length ss1"
      apply (case_tac "Ss ss1 (\<rho>,i)")
      apply (auto simp: seq_def) apply (case_tac "A a1 (\<rho>''@\<rho>)") apply auto done
    let ?s1 = "(\<rho>1@\<rho>,i')"
    from fe2 EPrim have IH2: "E e2 \<rho> i' = B (ss2,a2) (\<rho>,i')" by simp
    show ?thesis
    proof (cases "E e2 \<rho> i'")
      case None
      then show ?thesis sorry
    next
      case (Some r2)
      from Some obtain n2 i'' where Ee2: "E e2 \<rho> i' = Some (n2,i'')" by (cases r2) simp
      from Ee2 IH2 Sss_result[of ss2 \<rho> i'] obtain \<rho>2 where Sss2: "Ss ss2 (\<rho>,i') = Some (\<rho>2@\<rho>,i'')"
        and Aa2: "As a2 (\<rho>2@\<rho>,i'') = Some (n2,i'')" and lr2_ss2:"length \<rho>2 = length ss2"
        apply (case_tac "Ss ss2 (\<rho>,i')") apply (auto simp: seq_def)
        apply (case_tac "A a2 (\<rho>''@\<rho>)") apply auto done
      let ?s2 = "(\<rho>2@\<rho>1@\<rho>, i'')"

      from Sss2 ss2p lr1_ss1 lr2_ss2 shiftss_append_some[of ss2 "[]" \<rho> i' \<rho>2 i'' \<rho>1]
      have Ss_ss2p: "Ss ss2' ?s1 = Some ?s2" by simp

      from a1p lr1_ss1 lr2_ss2 have "A a1 (\<rho>1@\<rho>) = A a1' (\<rho>2@\<rho>1@\<rho>)"
        using shifta_append[of a1 "[]" "\<rho>1@\<rho>" \<rho>2]  by simp
      from this Aa1 have As_a1p: "As a1' ?s2 = Some (n1,i'')" apply simp
          apply (case_tac "A a1 (\<rho>1@\<rho>)") apply auto apply (case_tac "A a1' (\<rho>2 @ \<rho>1 @ \<rho>)") by auto

      from a2p lr1_ss1 lr2_ss2 have "A a2 (\<rho>2@\<rho>) = A a2' (\<rho>2@\<rho>1@\<rho>)"
        using shifta_append[of a2 \<rho>2 \<rho> \<rho>1] by simp
      from this Aa2 have As_a2p: "As a2' ?s2 = Some (n2,i'')" by simp

      from Ee1 Ee2 have Ep: "E (EPrim f e1 e2) \<rho> i = Some (f n1 n2, i'')" by simp

      from fp have "B (flatten (EPrim f e1 e2)) (\<rho>, i)
            = seq (Ss ss1) (seq (Ss ss2') (seq (Ss [Push (FPrim f a1' a2')]) (As (AVar 0)))) ?s0"
        by (simp add: seq_assoc)
      also from Ss_ss1 have "... = seq (Ss ss2') (seq (Ss [Push (FPrim f a1' a2')]) (As (AVar 0))) ?s1"
        by simp
      also from Ss_ss2p have "... = seq (Ss [Push (FPrim f a1' a2')]) (As (AVar 0)) ?s2" by simp
      also from As_a1p As_a2p have "... = Some (f n1 n2, i'')" apply (simp add: seq_def)
        apply (case_tac "A a1' (\<rho>2 @ \<rho>1 @ \<rho>)") apply auto
        apply (case_tac "A a2' (\<rho>2 @ \<rho>1 @ \<rho>)") apply (auto simp: ret_def) done
      finally have "B (flatten (EPrim f e1 e2)) (\<rho>, i) = Some (f n1 n2, i'')" .

      from this Ep EPrim show ?thesis by simp
    qed
  qed
next
  case (EVar x)
  then show ?case sorry
next
  case (ELet e1 e2)
  then show ?case sorry
qed

end


(*  Title:       Binary Search Trees, Isar-Style
    Author:      Viktor Kuncak, MIT CSAIL, November 2003
    Maintainer:  Larry Paulson <Larry.Paulson at cl.cam.ac.uk>
    License:     LGPL
*)

section \<open>Mostly Isar-style Reasoning for Binary Tree Operations\<close>
theory BinaryTree_Map imports BinaryTree begin

text \<open>We prove correctness of map operations
 implemented using binary search trees from BinaryTree.

 This document is LGPL.

 Author: Viktor Kuncak, MIT CSAIL, November 2003\<close>

(*============================================================*)
section \<open>Map implementation and an abstraction function\<close>
(*============================================================*)

type_synonym
  'a tarray = "(index * 'a) Tree"

definition valid_tmap :: "'a tarray => bool" where
  "valid_tmap t == sortedTree fst t"

declare valid_tmap_def [simp]

definition mapOf :: "'a tarray => index => 'a option" where
  \<comment> \<open>the abstraction function from trees to maps\<close>
  "mapOf t i ==
   (case (tlookup fst i t) of
     None => None
   | Some ia => Some (snd ia))"

(*============================================================*)
section \<open>Auxiliary Properties of our Implementation\<close>
(*============================================================*)

lemma mapOf_lookup1: "tlookup fst i t = None ==> mapOf t i = None"
by (simp add: mapOf_def)

lemma mapOf_lookup2: "tlookup fst i t = Some (j,a) ==> mapOf t i = Some a"
by (simp add: mapOf_def)

lemma assumes h: "mapOf t i = None"
      shows mapOf_lookup3: "tlookup fst i t = None"
proof (cases "tlookup fst i t")
case None from this show ?thesis by assumption
next case (Some ia) note tsome = this
  from this have o1: "tlookup fst i t = Some (fst ia, snd ia)" by simp
  have "mapOf t i = Some (snd ia)"
  by (insert mapOf_lookup2 [of i t "fst ia" "snd ia"], simp add: o1)
  from this have "mapOf t i ~= None" by simp
  from this h show ?thesis by simp \<comment> \<open>contradiction\<close>
qed

lemma assumes v: "valid_tmap t"
      assumes h: "mapOf t i = Some a"
      shows mapOf_lookup4: "tlookup fst i t = Some (i,a)"
proof (cases "tlookup fst i t")
case None
  from this mapOf_lookup1 have "mapOf t i = None" by auto
  from this h show ?thesis by simp \<comment> \<open>contradiction\<close>
next case (Some ia) note tsome = this
  have tlookup_some_inst: "sortedTree fst t & (tlookup fst i t = Some ia) -->
        ia : setOf t & fst ia = i" by (simp add: tlookup_some)
  from tlookup_some_inst tsome v have "ia : setOf t" by simp
  from tsome have "mapOf t i = Some (snd ia)" by (simp add: mapOf_def)
  from this h have o1: "snd ia = a" by simp
  from tlookup_some_inst tsome v have o2: "fst ia = i" by simp
  from o1 o2 have "ia = (i,a)" by auto
  from this tsome show "tlookup fst i t = Some (i, a)" by simp
qed

subsection \<open>Lemmas \<open>mapset_none\<close> and \<open>mapset_some\<close> establish
              a relation between the set and map abstraction of the tree\<close>

lemma assumes v: "valid_tmap t"
      shows mapset_none: "(mapOf t i = None) = (\<forall>a. (i,a) \<notin> setOf t)"
proof
  \<comment> \<open>==>\<close>
  assume mapNone: "mapOf t i = None"
  from v mapNone mapOf_lookup3 have lnone: "tlookup fst i t = None" by auto
  show "\<forall>a. (i,a) \<notin> setOf t"
  proof
    fix a
    show "(i,a) ~: setOf t"
    proof
      assume iain: "(i,a) : setOf t"
      have tlookup_none_inst:
      "sortedTree fst t & (tlookup fst i t = None) --> (\<forall>x \<in> setOf t. fst x ~= i)"
      by (insert tlookup_none [of "fst" "t" "i"], assumption)
      from v lnone tlookup_none_inst have "\<forall>x \<in> setOf t. fst x ~= i" by simp
      from this iain have "fst (i,a) ~= i" by fastforce
      from this show False by simp
    qed
  qed
  \<comment> \<open><==\<close>
  next assume h: "\<forall>a. (i,a) \<notin> setOf t"
  show "mapOf t i = None"
  proof (cases "mapOf t i")
  case None then show ?thesis .
  next case (Some a) note mapsome = this
    from v mapsome have o1: "tlookup fst i t = Some (i,a)" by (simp add: mapOf_lookup4)
    (* moving mapOf_lookup4 to assumption does not work, although it uses
       no == !! *)
    from tlookup_some have tlookup_some_inst:
    "sortedTree fst t & tlookup fst i t = Some (i,a) -->
     (i,a) : setOf t & fst (i,a) = i"
    by (insert tlookup_some [of fst t i "(i,a)"], assumption)
    from v o1 this have "(i,a) : setOf t" by simp
    from this h show ?thesis by auto \<comment> \<open>contradiction\<close>
  qed
qed

lemma assumes v: "valid_tmap t"
      shows mapset_some: "(mapOf t i = Some a) = ((i,a) : setOf t)"
proof
  \<comment> \<open>==>\<close>
  assume mapsome: "mapOf t i = Some a"
  from v mapsome have o1: "tlookup fst i t = Some (i,a)" by (simp add: mapOf_lookup4)
  from tlookup_some have tlookup_some_inst:
  "sortedTree fst t & tlookup fst i t = Some (i,a) -->
   (i,a) : setOf t & fst (i,a) = i"
  by (insert tlookup_some [of fst t i "(i,a)"], assumption)
  from v o1 this show "(i,a) : setOf t" by simp
  \<comment> \<open><==\<close>
  next assume iain: "(i,a) : setOf t"
  from v iain tlookup_finds have "tlookup fst (fst (i,a)) t = Some (i,a)" by fastforce
  from this have "tlookup fst i t = Some (i,a)" by simp
  from this show "mapOf t i = Some a" by (simp add: mapOf_def)
qed

(*============================================================*)
section \<open>Empty Map\<close>
(*============================================================*)

lemma mnew_spec_valid: "valid_tmap Tip"
by (simp add: mapOf_def)

lemma mtip_spec_empty: "mapOf Tip k = None"
by (simp add: mapOf_def)

(*============================================================*)
section \<open>Map Update Operation\<close>
(*============================================================*)

definition mupdate :: "index => 'a => 'a tarray => 'a tarray" where
  "mupdate i a t == binsert fst (i,a) t"

lemma assumes v: "valid_tmap t"
      shows mupdate_map: "mapOf (mupdate i a t) = (mapOf t)(i |-> a)"
proof
  fix i2
  let ?tr = "binsert fst (i,a) t"
  have upres: "mupdate i a t = ?tr" by (simp add: mupdate_def)
  from v binsert_set
  have setSpec: "setOf ?tr = setOf t - eqs fst (i,a) Un {(i,a)}" by fastforce
  from v binsert_sorted have vr: "valid_tmap ?tr" by fastforce
  show "mapOf (mupdate i a t) i2 = ((mapOf t)(i |-> a)) i2"
  proof (cases "i = i2")
  case True note i2ei = this
    from i2ei have rhs_res: "((mapOf t)(i |-> a)) i2 = Some a" by simp
    have lhs_res: "mapOf (mupdate i a t) i = Some a"
    proof -
      have will_find: "tlookup fst i ?tr = Some (i,a)"
      proof -
        from setSpec have kvin: "(i,a) : setOf ?tr" by simp
        have binsert_sorted_inst: "sortedTree fst t -->
                                 sortedTree fst ?tr"
        by (insert binsert_sorted [of "fst" "t" "(i,a)"], assumption)
        from v binsert_sorted_inst have rs: "sortedTree fst ?tr" by simp
        have tlookup_finds_inst: "sortedTree fst ?tr & (i,a) : setOf ?tr -->
                                  tlookup fst i ?tr = Some (i,a)"
        by (insert tlookup_finds [of "fst" "?tr" "(i,a)"], simp)
        from rs kvin tlookup_finds_inst show ?thesis by simp
      qed
      from upres will_find show ?thesis by (simp add: mapOf_def)
    qed
    from lhs_res rhs_res i2ei show ?thesis by simp
  next case False note i2nei = this
    from i2nei have rhs_res: "((mapOf t)(i |-> a)) i2 = mapOf t i2" by auto
    have lhs_res: "mapOf (mupdate i a t) i2 = mapOf t i2"
    proof (cases "mapOf t i2")
    case None from this have mapNone: "mapOf t i2 = None" by simp
      from v mapNone mapset_none have i2nin: "\<forall>a. (i2,a) \<notin> setOf t" by fastforce
      have noneIn: "\<forall>b. (i2,b) \<notin> setOf ?tr"
      proof
        fix b
        from v binsert_set
        have "setOf ?tr = setOf t - eqs fst (i,a) Un {(i,a)}"
        by fastforce
        from this i2nei i2nin show "(i2,b) ~: setOf ?tr" by fastforce
      qed
      have mapset_none_inst:
      "valid_tmap ?tr --> (mapOf ?tr i2 = None) = (\<forall>a. (i2, a) \<notin> setOf ?tr)"
      by (insert mapset_none [of "?tr" i2], simp)
      from vr noneIn mapset_none_inst have "mapOf ?tr i2 = None" by fastforce
      from this upres mapNone show ?thesis by simp
    next case (Some z) from this have mapSome: "mapOf t i2 = Some z" by simp
      from v mapSome mapset_some have "(i2,z) : setOf t" by fastforce
      from this setSpec i2nei have "(i2,z) : setOf ?tr" by (simp add: eqs_def)
      from this vr mapset_some have "mapOf ?tr i2 = Some z" by fastforce
      from this upres mapSome show ?thesis by simp
    qed
    from lhs_res rhs_res show ?thesis by simp
  qed
qed

lemma assumes v: "valid_tmap t"
      shows mupdate_valid: "valid_tmap (mupdate i a t)"
proof -
  let ?tr = "binsert fst (i,a) t"
  have upres: "mupdate i a t = ?tr" by (simp add: mupdate_def)
  from v binsert_sorted have vr: "valid_tmap ?tr" by fastforce
  from vr upres show ?thesis by simp
qed

(*============================================================*)
section \<open>Map Remove Operation\<close>
(*============================================================*)

definition mremove :: "index => 'a tarray => 'a tarray" where
  "mremove i t == remove fst (i, undefined) t"

lemma assumes v: "valid_tmap t"
      shows mremove_valid: "valid_tmap (mremove i t)"
proof (simp add: mremove_def)
  from v remove_sort
  show "sortedTree fst (remove fst (i, undefined) t)" by fastforce
qed

lemma assumes v: "valid_tmap t"
      shows mremove_map: "mapOf (mremove i t) i = None"
proof (simp add: mremove_def)
  let ?tr = "remove fst (i, undefined) t"
  show "mapOf ?tr i = None"
  proof -
    from v remove_spec
    have remSet: "setOf ?tr = setOf t - eqs fst (i, undefined)"
    by fastforce
    have noneIn: "\<forall>a. (i,a) \<notin> setOf ?tr"
    proof
      fix a
      from remSet show "(i,a) ~: setOf ?tr" by (simp add: eqs_def)
    qed
    from v remove_sort have vr: "valid_tmap ?tr" by fastforce
    have mapset_none_inst: "valid_tmap ?tr ==>
    (mapOf ?tr i = None) = (\<forall>a. (i,a) \<notin> setOf ?tr)"
    by (insert mapset_none [of "?tr" "i"], simp)
    from vr this have "(mapOf ?tr i = None) = (\<forall>a. (i,a) \<notin> setOf ?tr)" by fastforce
    from this noneIn show "mapOf ?tr i = None" by simp
  qed
qed

end