section \<open>Fixed-Width Integer Arithmetic\<close>
theory LLVM_DS_Arith
imports "../vcg/LLVM_VCG_Main"
begin

text \<open>Implementing integers and natural numbers
  by fixed-width integers\<close>

(* TODO: Move *)
definition snats :: "nat \<Rightarrow> nat set"
  where "snats n = {i. i < 2 ^ (n-1)}"

definition max_unat :: "nat \<Rightarrow> nat" where "max_unat n \<equiv> 2^n"
abbreviation (input) "min_uint \<equiv> 0::int"
definition max_uint :: "nat \<Rightarrow> int" where "max_uint n \<equiv> 2^n"

definition min_sint :: "nat \<Rightarrow> int" where "min_sint n \<equiv> -(2^(n-1))"
definition max_sint :: "nat \<Rightarrow> int" where "max_sint n \<equiv> 2^(n-1)"

definition "max_snat n \<equiv> (2::nat)^(n-1)"

lemma in_unats_conv[simp]: "x\<in>unats n \<longleftrightarrow> x<max_unat n" by (auto simp: unats_def max_unat_def)

lemma in_sints_conv[simp]: "n\<noteq>0 \<Longrightarrow> x\<in>sints n \<longleftrightarrow> min_sint n \<le> x \<and> x<max_sint n"
  by (auto simp: sints_num min_sint_def max_sint_def)

lemma in_uints_conv[simp]: "x\<in>uints n \<longleftrightarrow> min_uint \<le> x \<and> x<max_uint n"
  by (auto simp: uints_num max_uint_def)

lemma in_snats_conv[simp]: "n\<in>snats N \<longleftrightarrow> n<max_snat N"
  by (auto simp: snats_def max_snat_def)

lemma in_range_uint_conv[simp]: "x\<in>range (uint::'a::len word \<Rightarrow> _) \<longleftrightarrow> min_uint \<le> x \<and> x<max_uint LENGTH('a)"
  by (auto simp: uints_num max_uint_def word_uint.Rep_range)

lemma uint_lt_max_uint[simp]: "uint (w::'a::len word) < max_uint LENGTH('a)"
  using max_uint_def by auto

lemma unat_lt_max_unat[simp]: "unat (w::'a::len word) < max_unat LENGTH('a)"
  using max_unat_def by auto

lemma sint_cmp_extr_sint[simp]:
  "min_sint LENGTH('a) \<le> sint (w::'a::len word)"
  "sint (w::'a::len word) < max_sint LENGTH('a)"
  unfolding max_sint_def min_sint_def using sint_range' by auto

definition snat :: "_::len2 word \<Rightarrow> nat" where "snat \<equiv> nat o sint"

(* TODO: Move *)
lemma not_bin_nth_if_less: "\<lbrakk>0\<le>i; i<2^n\<rbrakk> \<Longrightarrow> \<not>(bin_nth i n)"
  apply auto
  using bintrunc_mod2p nth_bintr by force

lemma snat_zero[simp]: "snat 0 = 0" by (auto simp: snat_def)
lemma snat_one[simp]: "snat (1) = 1" by (auto simp: snat_def)

lemma snat_numeral[simp]:
  fixes b
  defines "w::'a::len2 word \<equiv> numeral b"
  defines "n::nat \<equiv> numeral b"
  assumes A: "n<max_snat LENGTH('a)"
  shows "snat w = n"
proof -
  have MSB: "\<not>msb w" using A
    apply (simp add: w_def n_def max_snat_def not_bin_nth_if_less)
    apply (rule not_bin_nth_if_less)
    apply simp
    by (metis of_nat_less_iff of_nat_numeral semiring_1_class.of_nat_power)

  have "snat w = nat (sint w)" by (simp add: snat_def)
  also have "sint w = uint w" using MSB by (simp add: sint_eq_uint)
  also have "\<dots> = numeral b mod 2^LENGTH('a)" unfolding w_def by (rule uint_numeral)
  also have "\<dots> = numeral b"
  proof (rule mod_pos_pos_trivial)
    have "int n < int (Suc 1 ^ len_of (TYPE('a)::'a itself))"
      by (metis One_nat_def assms(3) diff_le_self lessI max_snat_def numerals(2) of_nat_less_iff order_less_le_trans power_increasing_iff)
    then show "(numeral b::int) < 2 ^ len_of (TYPE('a)::'a itself)"
      by (simp add: n_def)
  qed simp
  finally show ?thesis unfolding n_def by simp
qed

abbreviation (input) "word_len \<equiv> \<lambda>_::'a::len0 word. LENGTH('a)"

lemma snat_lt_max_snat[simp]: "snat w < max_snat (word_len w)"
  by (auto simp: snat_def max_snat_def sint_range')

subsection \<open>Constant Folding\<close>
(*
   TODO: No idea how complete these are
*)
lemmas llvm_num_const_simps[llvm_inline]
  = Num.arith_simps power_numeral pred_numeral_simps power_0
    arith_special numeral_One[symmetric]

subsection \<open>Reflection of Maximum Representable Values\<close>

definition ll_max_uint :: "'l::len word llM" where [llvm_inline]: "ll_max_uint \<equiv> ll_sub 0 1"
definition ll_max_sint :: "'l::len2 word llM" where [llvm_inline]: "ll_max_sint \<equiv> doM {r \<leftarrow> ll_max_uint; ll_lshr r 1}"

context llvm_prim_arith_setup begin

lemma ll_max_uint_simp[vcg_normalize_simps]: "(ll_max_uint::'l::len word llM) = return (word_of_int (max_uint LENGTH('l) - 1))"
  unfolding ll_max_uint_def max_uint_def
  apply vcg_normalize
  done

lemma len_neq_one_conv:
  "LENGTH('l::len) \<noteq> Suc 0 \<longleftrightarrow> (\<exists>n. LENGTH('l) = Suc (Suc n))"
  apply auto
  by (metis One_nat_def Suc_pred' len_gt_0 neq0_conv)

lemma word_of_int_div2: "0\<le>w \<Longrightarrow> w<2^LENGTH('a) \<Longrightarrow> word_of_int w div (2::'a::len word) = word_of_int (w div 2)"
  apply (simp add: word_uint_eq_iff uint_word_of_int uint_div bintrunc_mod2p)
  by (smt int_mod_eq' mod_self zdiv_eq_0_iff)

lemma word_of_int_shr1: "0\<le>w \<Longrightarrow> w<2^LENGTH('a::len) \<Longrightarrow> (word_of_int w :: 'a word) >> Suc 0 = word_of_int (w div 2)"
  by (auto simp: shiftr1_is_div_2[simplified] word_of_int_div2)

lemma ll_max_sint_aux1: "((4::int) * 2 ^ n - 1) div 2 < 4 * 2 ^ n"
proof -
  have "((4::int) * 2 ^ n - 1) < (4::int) * 2 ^ n" by auto
  hence "((4::int) * 2 ^ n - 1) div 2 \<le> ((4::int) * 2 ^ n) div 2" by auto
  also have "\<dots> < 4 * 2^n" by auto
  finally show ?thesis .
qed

lemma ll_max_sint_simp[vcg_normalize_simps]: "(ll_max_sint::'l::len2 word llM) = return (word_of_int (max_sint LENGTH('l) - 1))"
  unfolding ll_max_sint_def
  apply vcg_normalize
  by (metis (mono_tags, lifting) One_nat_def arith_simps(1) arith_simps(45) exp_eq_zero_iff mask_eq_decr_exp max_sint_def max_uint_def numeral_code(1) of_int_numeral of_int_power of_nat_numeral semiring_1_class.of_nat_power shiftr_mask2 word_exp_length_eq_0)

lemma ll_max_uint_rule[vcg_rules]: "llvm_htriple \<box> (ll_max_uint::'l::len word llM) (\<lambda>r. \<up>(uint r = max_uint (LENGTH('l)) - 1))"
  supply [simp] = max_uint_def zmod_minus1 uint_word_ariths
  unfolding ll_max_uint_def max_uint_def
  by vcg'

lemma ll_max_sint_rule: "llvm_htriple (\<box>) (ll_max_sint::'l::len2 word llM) (\<lambda>r. \<up>(uint r = max_sint LENGTH('l) - 1))"
  apply vcg'
  apply (auto simp add: uint_word_of_int max_sint_def)
  by (smt (z3) One_nat_def diff_less len_gt_0 lessI linorder_not_less msb_big msb_uint_big sint_range' uint_arith_simps(4) unsigned_1 word_less_sub_le word_power_less_1)

end

subsection \<open>Signed Integers\<close>

interpretation sint: standard_opr_abstraction sint
  "\<lambda>_. True"
  "\<lambda>op (_::'a::len word itself) a. op a \<in> sints LENGTH('a)"
  "\<lambda>op (_::'a::len word itself) a b. op a b \<in> sints LENGTH('a)"
  "\<lambda>a c. a\<in>sints LENGTH('a)"
  by standard auto

method prove_sint_op uses simp = (
  rule sint.is_bin_opI sint.is_cmp_opI sint.is_un_opI;
  (auto simp: min_sint_def max_sint_def vcg_normalize_simps simp)?;
  (determ uint_arith; fail)?)

lemma sint_neq_ZD: "sint b \<noteq> 0 \<Longrightarrow> b\<noteq>0" by auto

context begin

interpretation llvm_prim_arith_setup .

lemma sint_bin_ops:
  "sint.is_bin_op' ll_add (+) (+)"
  "sint.is_bin_op' ll_sub (-) (-)"
  "sint.is_bin_op' ll_mul (*) (*)"
  "sint.is_bin_op (\<lambda>(_::'a::len word itself) a b. b\<noteq>0 \<and> a sdiv b \<in> sints LENGTH('a)) ll_sdiv (sdiv) (sdiv)"
  "sint.is_bin_op (\<lambda>(_::'a::len word itself) a b. b\<noteq>0 \<and> a sdiv b \<in> sints LENGTH('a)) ll_srem (smod) (smod)"
  supply [simp del] = in_sints_conv
  apply (all \<open>prove_sint_op simp:  sint_neq_ZD\<close>)
  apply (simp_all add: sbintrunc_eq_if_in_range sint_word_ariths signed_mod_arith signed_div_arith)
  using smod_word_min smod_word_max
  by (auto simp add: in_sints_conv min_sint_def max_sint_def)

lemma sint_cmp_ops:
  "sint.is_cmp_op ll_icmp_eq (=) (=)"
  "sint.is_cmp_op ll_icmp_ne (\<noteq>) (\<noteq>)"
  "sint.is_cmp_op ll_icmp_sle (\<lambda>a b. a <=s b) (\<le>)" (* FIXME: Why isn't <=s and <s proper infix operator? *)
  "sint.is_cmp_op ll_icmp_slt (\<lambda>a b. a <s b) (<)"
  by (all \<open>prove_sint_op simp: word_sle_def word_sless_def le_less\<close>)

lemmas sint_rules[vcg_rules] =
  sint_bin_ops[THEN sint.bin_op_tmpl]
  sint_cmp_ops[THEN sint.cmp_op_tmpl]

definition signed :: "'a::len word \<Rightarrow> 'a word" where [llvm_inline]: "signed c \<equiv> c"

declare [[vcg_const "signed (numeral a)"]]
declare [[vcg_const "signed (-numeral a)"]]
declare [[vcg_const "signed 0"]]
declare [[vcg_const "signed (-0)"]]
declare [[vcg_const "signed 1"]]
declare [[vcg_const "signed (-1)"]]

lemma monadify_signed[vcg_monadify_xforms]:
  "return (signed x) = ll_const (signed x)" by (simp add: ll_const_def)

lemma ll_const_signed_aux: "\<lbrakk>n\<noteq>0; - (2 ^ (n - Suc 0)) \<le> i; i < 2 ^ (n - Suc 0)\<rbrakk>
         \<Longrightarrow> (i + 2 ^ (n - Suc 0)) mod 2 ^ n - 2 ^ (n - Suc 0) = (i::int)"
  by (cases n; simp)

lemma ll_const_signed_rule[vcg_rules]:
  "llvm_htriple \<box> (ll_const (signed 0)) (\<lambda>r. \<upharpoonleft>sint.assn 0 r)"
  "llvm_htriple (\<up>\<^sub>d(LENGTH('a::len) \<noteq> 1)) (ll_const (signed (1::'a word))) (\<lambda>r. \<upharpoonleft>sint.assn 1 r)"
  "llvm_htriple (\<up>\<^sub>d(numeral w \<in> sints LENGTH('a))) (ll_const (signed (numeral w::'a::len word))) (\<lambda>r. \<upharpoonleft>sint.assn (numeral w) r)"
  unfolding ll_const_def signed_def sint.assn_def
  supply [simp] = sbintrunc_mod2p max_sint_def min_sint_def ll_const_signed_aux
  by vcg

(* TODO: Move *)
lemma lt_exp2n_signed_estimate[simp]:
  fixes x::int
  defines "n\<equiv>LENGTH('a::len)"
  assumes A: "ASSUMPTION (n > n')" "x<2^n'"
  shows "x < max_sint n"
  using A unfolding ASSUMPTION_def max_sint_def
  by (smt One_nat_def Suc_le_mono Suc_pred assms(1) len_gt_0 less_eq_Suc_le power_increasing_iff)

end

subsection \<open>Unsigned Integers\<close>

interpretation uint: standard_opr_abstraction uint
  "\<lambda>_. True"
  "\<lambda>op (_::'a::len word itself) a. op a \<in> uints LENGTH('a)"
  "\<lambda>op (_::'a::len word itself) a b. op a b \<in> uints LENGTH('a)"
  "\<lambda>a c. a\<in>uints LENGTH('a)"
  by standard auto

method prove_uint_op uses simp = (
  rule uint.is_bin_opI uint.is_cmp_opI uint.is_un_opI;
  (auto simp: max_uint_def vcg_normalize_simps simp)?;
  (determ uint_arith; fail)?)

lemma uint_neq_ZD: "uint b \<noteq> 0 \<Longrightarrow> b\<noteq>0" by auto

context begin

interpretation llvm_prim_arith_setup .

lemma uint_bin_ops_arith:
  "uint.is_bin_op (\<lambda>(_::'a::len word itself) a b. a+b < max_uint LENGTH('a)) ll_add (+) (+)"
  "uint.is_bin_op (\<lambda>_ a b. b\<le>a) ll_sub (-) (-)"
  "uint.is_bin_op (\<lambda>(_::'a::len word itself) a b. a*b < max_uint LENGTH('a)) ll_mul (*) (*)"
  "uint.is_bin_op (\<lambda>_ a b. b\<noteq>0) ll_udiv (div) (div)"
  "uint.is_bin_op (\<lambda>_ a b. b\<noteq>0) ll_urem (mod) (mod)"
  by (all \<open>prove_uint_op simp: uint_mult_lem uint_neq_ZD uint_div uint_mod\<close>)

(* TODO: Remove preconditions! *)
lemma uint_bin_ops_bitwise:
  "uint.is_bin_op (\<lambda>_ _ _. True) ll_and (AND) (AND)"
  "uint.is_bin_op (\<lambda>_ _ _. True) ll_or (OR) (OR)"
  "uint.is_bin_op (\<lambda>_ _ _. True) ll_xor (XOR) (XOR)"
  by (all \<open>prove_uint_op simp: uint_and uint_or uint_xor\<close>)

lemmas uint_bin_ops = uint_bin_ops_arith uint_bin_ops_bitwise

lemma uint_cmp_ops:
  "uint.is_cmp_op ll_icmp_eq (=) (=)"
  "uint.is_cmp_op ll_icmp_ne (\<noteq>) (\<noteq>)"
  "uint.is_cmp_op ll_icmp_ule (\<le>) (\<le>)"
  "uint.is_cmp_op ll_icmp_ult (<) (<)"
  by (all \<open>prove_uint_op\<close>)

lemmas uint_rules[vcg_rules] =
  uint_bin_ops[THEN uint.bin_op_tmpl]
  uint_cmp_ops[THEN uint.cmp_op_tmpl]

definition unsigned :: "'a::len word \<Rightarrow> 'a word" where [llvm_inline]: "unsigned c \<equiv> c"

declare [[vcg_const "unsigned (numeral a)"]]
declare [[vcg_const "unsigned 0"]]
declare [[vcg_const "unsigned 1"]]

lemma monadify_unsigned[vcg_monadify_xforms]:
  "return (unsigned x) = ll_const (unsigned x)" by (simp add: ll_const_def)

lemma ll_const_unsigned_rule[vcg_rules]:
  "llvm_htriple \<box> (ll_const (unsigned 0)) (\<lambda>r. \<upharpoonleft>uint.assn 0 r)"
  "llvm_htriple \<box> (ll_const (unsigned 1)) (\<lambda>r. \<upharpoonleft>uint.assn 1 r)"
  "llvm_htriple (\<up>\<^sub>d(numeral w \<in> uints LENGTH('a))) (ll_const (unsigned (numeral w::'a::len word))) (\<lambda>r. \<upharpoonleft>uint.assn (numeral w) r)"
  unfolding ll_const_def unsigned_def uint.assn_def
  supply [simp] = bintrunc_mod2p max_uint_def
  by vcg

(* TODO: Move *)
lemma lt_exp2n_estimate[simp]:
  fixes x::int
  defines "n\<equiv>LENGTH('a::len)"
  assumes A: "ASSUMPTION (n \<ge> n')" "x<2^n'"
  shows "x < max_uint n"
  using A unfolding ASSUMPTION_def max_uint_def
  by (smt power_increasing_iff)

end

subsubsection \<open>Natural Numbers by unsigned\<close>

find_theorems "uint _ < max_uint _"

interpretation unat: standard_opr_abstraction unat
  "\<lambda>_. True"
  "\<lambda>op (_::'a::len word itself) a. op a \<in> unats LENGTH('a)"
  "\<lambda>op (_::'a::len word itself) a b. op a b \<in> unats LENGTH('a)"
  "\<lambda>a c. a\<in>unats LENGTH('a)"
  by standard auto

method prove_unat_op uses simp = (
  rule unat.is_bin_opI unat.is_un_opI unat.is_cmp_opI;
  (auto simp: max_unat_def vcg_normalize_simps simp)?;
  (determ unat_arith; fail)?)

lemma unat_neq_ZD: "unat b \<noteq> 0 \<Longrightarrow> b\<noteq>0" by auto

context begin

interpretation llvm_prim_arith_setup .

lemma unat_bin_ops:
  "unat.is_bin_op (\<lambda>(_::'a::len word itself) a b. a+b < max_unat LENGTH('a)) ll_add (+) (+)"
  "unat.is_bin_op (\<lambda>_ a b. b\<le>a) ll_sub (-) (-)"
  "unat.is_bin_op (\<lambda>(_::'a::len word itself) a b. a*b < max_unat LENGTH('a)) ll_mul (*) (*)"
  "unat.is_bin_op (\<lambda>_ a b. b\<noteq>0) ll_udiv (div) (div)"
  "unat.is_bin_op (\<lambda>_ a b. b\<noteq>0) ll_urem (mod) (mod)"
  by (all \<open>prove_unat_op simp: unat_mult_lem unat_neq_ZD unat_div unat_mod\<close>)

lemma unat_bin_ops_bitwise:
  "unat.is_bin_op (\<lambda>_ _ _. True) ll_and (AND) (AND)"
  "unat.is_bin_op (\<lambda>_ _ _. True) ll_or (OR) (OR)"
  "unat.is_bin_op (\<lambda>_ _ _. True) ll_xor (XOR) (XOR)"
  by (all \<open>prove_unat_op simp: unsigned_and_eq unsigned_or_eq unsigned_xor_eq\<close>)

lemma unat_un_ops: "unat.is_un_op' (\<lambda>x. ll_add x 1) (\<lambda>x. x+1) Suc"
  by (prove_unat_op simp: unat_word_ariths)

lemma unat_cmp_ops:
  "unat.is_cmp_op ll_icmp_eq (=) (=)"
  "unat.is_cmp_op ll_icmp_ne (\<noteq>) (\<noteq>)"
  "unat.is_cmp_op ll_icmp_ule (\<le>) (\<le>)"
  "unat.is_cmp_op ll_icmp_ult (<) (<)"
  by (all \<open>prove_unat_op\<close>)

lemmas unat_rules[vcg_rules] =
  unat_bin_ops[THEN unat.bin_op_tmpl]
  unat_un_ops[THEN unat.un_op_tmpl]
  unat_cmp_ops[THEN unat.cmp_op_tmpl]

definition unsigned_nat :: "'a::len word \<Rightarrow> 'a word" where [llvm_inline]: "unsigned_nat c \<equiv> c"

declare [[vcg_const "unsigned_nat (numeral a)"]]
declare [[vcg_const "unsigned_nat 0"]]
declare [[vcg_const "unsigned_nat 1"]]

lemma monadify_unsigned_nat[vcg_monadify_xforms]:
  "return (unsigned_nat x) = ll_const (unsigned_nat x)"
  by (simp add: ll_const_def)

lemma ll_const_unsigned_nat_rule[vcg_rules]:
  "llvm_htriple \<box> (ll_const (unsigned_nat 0)) (\<lambda>r. \<upharpoonleft>unat.assn 0 r)"
  "llvm_htriple \<box> (ll_const (unsigned_nat 1)) (\<lambda>r. \<upharpoonleft>unat.assn 1 r)"
  "llvm_htriple (\<up>\<^sub>d(numeral w \<in> unats LENGTH('a))) (ll_const (unsigned_nat (numeral w::'a::len word))) (\<lambda>r. \<upharpoonleft>unat.assn (numeral w) r)"
  unfolding ll_const_def unsigned_nat_def unat.assn_def
  supply [simp] = bintrunc_mod2p max_unat_def unat_numeral and [simp del] = unat_bintrunc unsigned_numeral
  apply vcg
  done

(* TODO: Move *)
lemma lt_exp2n_nat_estimate[simp]:
  fixes x::nat
  defines "n\<equiv>LENGTH('a::len)"
  assumes A: "ASSUMPTION (n \<ge> n')" "x<2^n'"
  shows "x < max_unat n"
  using A unfolding ASSUMPTION_def max_unat_def
  by (metis leD leI le_less_trans less_nat_zero_code nat_power_less_imp_less
      nat_zero_less_power_iff pow_mono_leq_imp_lt)

end

subsection \<open>Natural Numbers by signed\<close>

definition "snat_invar (w::'a::len2 word) \<equiv> \<not>msb w"
interpretation snat: standard_opr_abstraction snat "snat_invar"
  "\<lambda>op (_::'a::len2 word itself) a. op a \<in> snats LENGTH('a)"
  "\<lambda>op (_::'a::len2 word itself) a b. op a b \<in> snats LENGTH('a)"
  "\<lambda>a c. a\<in>snats LENGTH('a)"
  apply standard apply (auto simp: snat_invar_def) done

lemma snat_invar_alt: "snat_invar (w::'a::len2 word) \<longleftrightarrow> (\<exists>n. word_len w = Suc n \<and> unat w < 2^n)"
  apply (cases "word_len w")
  apply (auto simp: snat_invar_def msb_unat_big)
  done

lemma snat_eq_unat_aux1: "unat w < 2^(word_len w - 1) \<Longrightarrow> snat w = unat w"
  apply (auto simp: snat_invar_alt snat_def)
  apply transfer
  apply auto
  apply (subst signed_take_bit_eq_if_positive)
  subgoal
    by (metis One_nat_def Suc_pred' bin_nth_take_bit_iff len_gt_0 lessI not_bin_nth_if_less not_le not_take_bit_negative)
  subgoal
    by (metis bintrunc_bintrunc diff_le_self take_bit_int_eq_self_iff take_bit_tightened)
  done

lemma snat_eq_unat_aux2:
  "snat_invar w \<Longrightarrow> snat w = unat w"
  by (auto simp: snat_invar_alt snat_eq_unat_aux1)

lemmas snat_eq_unat = snat_eq_unat_aux1 snat_eq_unat_aux2

lemma cnv_snat_to_uint:
  assumes "snat_invar w"
  shows "snat w = nat (uint w)"
    and "sint w = uint w"
    and "unat w = nat (uint w)"
  using assms apply -
  apply (simp add: snat_eq_unat(2)  sint_eq_uint)
  apply (simp add: sint_eq_uint snat_invar_def)
  apply (simp add: )
  done

method prove_snat_op uses simp = (
  rule snat.is_bin_opI snat.is_un_opI snat.is_cmp_opI;
  (auto simp: max_snat_def snat_invar_alt snat_eq_unat vcg_normalize_simps simp)?)

context begin

interpretation llvm_prim_arith_setup .

lemma snat_in_bounds_aux: "(a::nat)<2^(x-Suc 0) \<Longrightarrow> a<2^x"
  by (metis diff_le_self leI le_less_trans less_not_refl nat_power_less_imp_less numeral_2_eq_2 zero_less_Suc)

lemma snat_bin_ops:
  "snat.is_bin_op' ll_add (+) (+)"
  "snat.is_bin_op (\<lambda>_ a b. b\<le>a) ll_sub (-) (-)"
  "snat.is_bin_op' ll_mul (*) (*)"
  "snat.is_bin_op (\<lambda>_ a b. b\<noteq>0) ll_udiv (div) (div)"
  "snat.is_bin_op (\<lambda>_ a b. b\<noteq>0) ll_urem (mod) (mod)"

  apply (prove_snat_op simp: unat_word_ariths)
  apply (prove_snat_op simp: unat_word_ariths unat_sub_if')
  apply (prove_snat_op simp: unat_word_ariths)
  subgoal
    apply (prove_snat_op simp: unat_word_ariths)
    apply (subst ll_udiv_simp; auto)
    apply (metis div_le_dividend le_less_trans power_Suc unat_div unat_of_nat word_arith_nat_defs(6))
    apply (subst snat_eq_unat)
    apply (auto simp: unat_div)
    apply (metis div_le_dividend le_less_trans)
    done
  subgoal
    apply (prove_snat_op simp: unat_word_ariths)
    apply (subst ll_urem_simp; auto)
    apply (meson le_less_trans mod_less_eq_dividend)
    apply (subst snat_eq_unat)
    apply (auto simp: unat_mod)
    apply (meson le_less_trans mod_less_eq_dividend)
    done
  done

lemma snat_un_ops: "snat.is_un_op' (\<lambda>x. ll_add x 1) (\<lambda>x. x+1) Suc"
  by (prove_snat_op simp: unat_word_ariths)

lemma snat_cmp_ops:
  "snat.is_cmp_op ll_icmp_eq (=) (=)"
  "snat.is_cmp_op ll_icmp_ne (\<noteq>) (\<noteq>)"
  "snat.is_cmp_op ll_icmp_ule (\<le>) (\<le>)"
  "snat.is_cmp_op ll_icmp_ult (<) (<)"
  "snat.is_cmp_op ll_icmp_sle (\<lambda>a b. a <=s b) (\<le>)"
  "snat.is_cmp_op ll_icmp_slt (\<lambda>a b. a <s b) (<)"

  apply (prove_snat_op)
  apply (prove_snat_op)
  apply (prove_snat_op simp: word_le_nat_alt word_less_nat_alt)
  apply (prove_snat_op simp: word_le_nat_alt word_less_nat_alt)
  apply (prove_snat_op simp: word_le_nat_alt word_less_nat_alt word_sle_msb_le msb_unat_big)
  apply (prove_snat_op simp: word_le_nat_alt word_less_nat_alt word_sle_msb_le word_sless_msb_less msb_unat_big)
  done

lemmas snat_rules[vcg_rules] =
  snat_bin_ops[THEN snat.bin_op_tmpl]
  snat_un_ops[THEN snat.un_op_tmpl]
  snat_cmp_ops[THEN snat.cmp_op_tmpl]

definition signed_nat :: "'a::len2 word \<Rightarrow> 'a word" where [llvm_inline]: "signed_nat c \<equiv> c"

declare [[vcg_const "signed_nat (numeral a)"]]
declare [[vcg_const "signed_nat 0"]]
declare [[vcg_const "signed_nat 1"]]

lemma monadify_signed_nat[vcg_monadify_xforms]: "return (signed_nat x) = ll_const (signed_nat x)" by (simp add: ll_const_def)

lemma ll_const_signed_nat_aux1: "(w::nat) < 2^(n-1) \<Longrightarrow> w mod (2^n) = w"
  by (simp add: snat_in_bounds_aux)

lemma ll_const_signed_nat_aux2: "\<lbrakk>numeral w < (2::nat) ^ (LENGTH('a::len2) - Suc 0)\<rbrakk> \<Longrightarrow> \<not>msb (numeral w::'a word)"
  apply (auto simp: msb_unat_big snat_in_bounds_aux unat_numeral simp del: unat_bintrunc)
  by (meson le_less_trans linorder_not_less take_bit_nat_less_eq_self)

lemma ll_const_signed_nat_rule[vcg_rules]:
  "llvm_htriple (\<box>) (ll_const (signed_nat (0::'a word))) (\<lambda>r. \<upharpoonleft>snat.assn 0 r)"
  "llvm_htriple (\<box>) (ll_const (signed_nat (1::'a word))) (\<lambda>r. \<upharpoonleft>snat.assn 1 r)"
  "llvm_htriple (\<up>\<^sub>d(numeral w \<in> snats LENGTH('a))) (ll_const (signed_nat (numeral w::'a::len2 word))) (\<lambda>r. \<upharpoonleft>snat.assn (numeral w) r)"
  unfolding ll_const_def signed_nat_def snat.assn_def
  apply vcg'
  subgoal by (simp add: not0_implies_Suc snat_invar_alt)
  subgoal by (simp add: snat_invar_def)
  subgoal
    apply (cases "LENGTH('a)"; simp)
    by (metis One_nat_def ll_const_signed_nat_aux2 max_snat_def snat_invar_def)
  done

end

lemma lt_exp2n_snat_estimate[simp]:
  fixes x::nat
  defines "n\<equiv>LENGTH('a::len)"
  assumes A: "ASSUMPTION (n > n')" "x<2^n'"
  shows "x < max_snat n"
  using A unfolding ASSUMPTION_def max_snat_def
  by (metis Suc_diff_1 Suc_leI leI le_less_trans nat_power_less_imp_less numeral_2_eq_2 order_less_irrefl zero_less_Suc)

definition [llvm_inline]: "ll_max_snat \<equiv> ll_max_sint"

lemma ll_max_snat_rule[vcg_rules]: "llvm_htriple (\<box>) ll_max_snat (\<lambda>r::'l word. \<upharpoonleft>snat.assn (max_snat LENGTH('l::len2) - 1) r)"
proof -
  interpret llvm_prim_arith_setup .

  note [simp del] = of_int_diff

  have [simp]: "snat_invar (word_of_int (max_sint LENGTH('l) - 1)::'l word)"
    apply (rule len2E[where 'a='l]; simp)
    apply (auto simp: snat_invar_alt len_neq_one_conv max_sint_def max_snat_def snat_def uint_word_of_int of_int_diff)
    by (metis eq_or_less_helperD lessI power_Suc)

  have 1[simp]: "snat_invar ((word_of_int (max_sint LENGTH('l))::'l word) - 1)"
    apply (rule len2E[where 'a='l]; simp)
    apply (auto simp: snat_invar_alt len_neq_one_conv max_sint_def max_snat_def snat_def uint_word_of_int)
    by (metis eq_or_less_helperD lessI power_Suc)

  show ?thesis
    unfolding ll_max_snat_def snat.assn_def
    apply vcg'
    apply (subst cnv_snat_to_uint, simp)
    apply (simp only: uint_word_of_int)
    apply (clarsimp simp: len_neq_one_conv max_sint_def max_snat_def snat_def snat_invar_alt)
    apply (simp add: nat_mod_distrib nat_mult_distrib nat_diff_distrib' nat_power_eq less_imp_diff_less)
    done

qed

subsection \<open>Casting\<close>

(* TODO: Add other casts.

  up/down * su/us/ss/uu

  and su_conv, us_conv

  Some casts might be expressable as up/downcast followed by conv!
*)

context begin
  interpretation llvm_prim_arith_setup .

  definition [llvm_inline]: "unat_snat_upcast TYPE('a::len2) x \<equiv> ll_zext x TYPE('a word)"
  definition [llvm_inline]: "snat_unat_downcast TYPE('a::len) x \<equiv> ll_trunc x TYPE('a word)"

  definition [llvm_inline]: "snat_snat_upcast TYPE('a::len2) x \<equiv> ll_zext x TYPE('a word)"
  definition [llvm_inline]: "snat_snat_downcast TYPE('a::len) x \<equiv> ll_trunc x TYPE('a word)"

  definition [llvm_inline]: "unat_unat_upcast TYPE('a::len) x \<equiv> ll_zext x TYPE('a word)"
  definition [llvm_inline]: "unat_unat_downcast TYPE('a::len) x \<equiv> ll_trunc x TYPE('a word)"

  definition unat_snat_conv :: "'l::len2 word \<Rightarrow> 'l word llM"
    where [llvm_inline]: "unat_snat_conv x \<equiv> return x"

  definition snat_unat_conv :: "'l::len2 word \<Rightarrow> 'l word llM"
    where [llvm_inline]: "snat_unat_conv x \<equiv> return x"

  lemma unat_snat_upcast_rule[vcg_rules]:
    "llvm_htriple
      (\<up>(is_up' UCAST('small \<rightarrow> 'big)) ** \<upharpoonleft>unat.assn n (ni::'small::len word))
      (unat_snat_upcast TYPE('big::len2) ni)
      (\<lambda>r. \<upharpoonleft>snat.assn n r)"
    unfolding unat.assn_def snat.assn_def unat_snat_upcast_def
    apply vcg'
    apply (auto simp: snat_invar_def snat_eq_unat(2) unat_ucast_upcast)
    done

  lemma snat_unat_downcast_rule[vcg_rules]:
    "llvm_htriple
      (\<up>(is_down' UCAST('big \<rightarrow> 'small)) ** \<upharpoonleft>snat.assn n (ni::'big::len2 word) ** \<up>(n<max_unat LENGTH('small)))
      (snat_unat_downcast TYPE('small::len) ni)
      (\<lambda>r. \<upharpoonleft>unat.assn n r)"
    unfolding unat.assn_def snat.assn_def snat_unat_downcast_def
    apply vcg'
    apply (auto simp: snat_invar_def snat_eq_unat(2) max_unat_def)
    by (metis ucast_nat_def unat_of_nat_eq)

  lemma snat_snat_upcast_rule[vcg_rules]:
    "llvm_htriple
      (\<up>(is_up' UCAST('small \<rightarrow> 'big)) ** \<upharpoonleft>snat.assn n (ni::'small::len2 word))
      (snat_snat_upcast TYPE('big::len2) ni)
      (\<lambda>r. \<upharpoonleft>snat.assn n r)"
    unfolding unat.assn_def snat.assn_def snat_snat_upcast_def
    apply vcg'
    apply (auto simp: snat_invar_def snat_eq_unat(2) unat_ucast_upcast)
    done

  lemma snat_snat_downcast_rule[vcg_rules]:
    "llvm_htriple
      (\<up>(is_down' UCAST('big \<rightarrow> 'small)) ** \<upharpoonleft>snat.assn n (ni::'big::len2 word) ** \<up>(n<max_snat LENGTH('small)))
      (snat_snat_downcast TYPE('small::len2) ni)
      (\<lambda>r. \<upharpoonleft>snat.assn n r)"
    unfolding snat.assn_def snat_snat_downcast_def
    apply vcg'
    apply (clarsimp simp: snat_invar_def max_snat_def)
    by (metis One_nat_def le_def msb_unat_big snat_eq_unat(1) snat_in_bounds_aux ucast_nat_def unat_of_nat_len)

   lemma unat_unat_upcast_rule[vcg_rules]:
    "llvm_htriple
      (\<up>(is_up' UCAST('small \<rightarrow> 'big)) ** \<upharpoonleft>unat.assn n (ni::'small::len word))
      (unat_unat_upcast TYPE('big::len) ni)
      (\<lambda>r. \<upharpoonleft>unat.assn n r)"
    unfolding unat.assn_def snat.assn_def unat_unat_upcast_def
    apply vcg'
    apply (auto simp: snat_invar_def snat_eq_unat(2) unat_ucast_upcast)
    done

  lemma unat_unat_downcast_rule[vcg_rules]:
    "llvm_htriple
      (\<up>(is_down' UCAST('big \<rightarrow> 'small)) ** \<upharpoonleft>unat.assn n (ni::'big::len word) ** \<up>(n<max_unat LENGTH('small)))
      (unat_unat_downcast TYPE('small::len) ni)
      (\<lambda>r. \<upharpoonleft>unat.assn n r)"
    unfolding unat.assn_def unat.assn_def unat_unat_downcast_def
    apply vcg'
    apply (auto simp: snat_invar_def snat_eq_unat(2) max_unat_def)
    by (metis ucast_nat_def unat_of_nat_eq)

  lemma unat_snat_conv_rule[vcg_rules]:
    "llvm_htriple (\<upharpoonleft>unat.assn x (xi::'l::len2 word) ** \<up>(x<max_snat LENGTH('l))) (unat_snat_conv xi) (\<lambda>r. \<upharpoonleft>snat.assn x r)"
    unfolding unat_snat_conv_def unat.assn_def snat.assn_def
    apply vcg'
    by (force simp: max_snat_def snat_invar_alt snat_eq_unat(1))

  lemma snat_unat_conv_rule[vcg_rules]:
    "llvm_htriple (\<upharpoonleft>snat.assn x (xi::'l::len2 word)) (snat_unat_conv xi) (\<lambda>r. \<upharpoonleft>unat.assn x r)"
    unfolding snat_unat_conv_def unat.assn_def snat.assn_def
    apply vcg'
    by (force simp: max_snat_def snat_invar_alt snat_eq_unat(1))

end

end


(*  Title:      Sequents/Washing.thy
    Author:     Sara Kalvala
*)

theory Washing
imports ILL
begin

axiomatization
  dollar :: o and
  quarter :: o and
  loaded :: o and
  dirty :: o and
  wet :: o and
  clean :: o
where
  change:
  "dollar \<turnstile> (quarter >< quarter >< quarter >< quarter)" and

  load1:
  "quarter , quarter , quarter , quarter , quarter \<turnstile> loaded" and

  load2:
  "dollar , quarter \<turnstile> loaded" and

  wash:
  "loaded , dirty \<turnstile> wet" and

  dry:
  "wet, quarter , quarter , quarter \<turnstile> clean"

(* "activate" definitions for use in proof *)

ML \<open>ML_Thms.bind_thms ("changeI", [@{thm context1}] RL ([@{thm change}] RLN (2,[@{thm cut}])))\<close>
ML \<open>ML_Thms.bind_thms ("load1I", [@{thm context1}] RL ([@{thm load1}] RLN (2,[@{thm cut}])))\<close>
ML \<open>ML_Thms.bind_thms ("washI", [@{thm context1}] RL ([@{thm wash}] RLN (2,[@{thm cut}])))\<close>
ML \<open>ML_Thms.bind_thms ("dryI", [@{thm context1}] RL ([@{thm dry}] RLN (2,[@{thm cut}])))\<close>

(* a load of dirty clothes and two dollars gives you clean clothes *)

lemma "dollar , dollar , dirty \<turnstile> clean"
  by (best add!: changeI load1I washI dryI)

(* order of premises doesn't matter *)

lemma "dollar , dirty , dollar \<turnstile> clean"
  by (best add!: changeI load1I washI dryI)

(* alternative formulation *)

lemma "dollar , dollar \<turnstile> dirty -o clean"
  by (best add!: changeI load1I washI dryI)

end


theory ValueSimilarity
imports Value CValue Pointwise
begin

text \<open>
This theory formalizes Section 3 of \cite{functionspaces}. Their domain $D$ is our type @{typ Value},
their domain $E$ is our type @{typ CValue} and $A$ corresponds to @{typ "(C \<rightarrow> CValue)"}.

In our case, the construction of the domains was taken care of by the HOLCF package
(\cite{holcf}), so where \cite{functionspaces} refers to elements of the domain approximations
$D_n$ resp. $E_n$, these are just elements of @{typ Value} resp. @{typ CValue} here. Therefore the
\emph{n-injection} $\phi_n^E \colon E_n \to E$ is the identity here.

The projections correspond to the take-functions generated by the HOLCF package:
\begin{alignstar}
\psi_n^E &\colon E \to E_n &\text{ corresponds to }&&@{term CValue_take}\<open>::\<close>&@{typeof "CValue_take :: nat \<Rightarrow> CValue \<rightarrow> CValue" } \\
\psi_n^A &\colon A \to A_n &\text{ corresponds to }&&@{term C_to_CValue_take}\<open>::\<close>&@{typeof "C_to_CValue_take :: nat \<Rightarrow> (C \<rightarrow> CValue) \<rightarrow> (C \<rightarrow> CValue)"} \\
\psi_n^D &\colon D \to D_n &\text{ corresponds to }&&@{term Value_take}\<open>::\<close>&@{typeof Value_take}.
\end{alignstar}

The syntactic overloading of $e(a)(c)$ to mean either $\mathrm{ |mathsf{Ap}}_{E_n}^|bot$ or $\mathrm{ |mathsf{AP}}_{E}^|bot$
turns into our non-overloaded \<open>_ \<down>CFn _\<close>\<open>::\<close>@{typeof "(\<down>CFn)"}.
\<close>

text \<open>
To have our presentation closer to \cite{functionspaces}, we introduce some notation:
\<close>

notation Value_take ("\<psi>\<^sup>D\<^bsub>_\<^esub>")
notation C_to_CValue_take ("\<psi>\<^sup>A\<^bsub>_\<^esub>")
notation CValue_take ("\<psi>\<^sup>E\<^bsub>_\<^esub>")

subsubsection \<open>A note about section 2.3\<close>

text \<open>
Section 2.3 of  \cite{functionspaces} contains equations (2) and (3) which do not hold in general.
We demonstrate that fact here using our corresponding definition, but the counter-example carries
over to the original formulation. Lemma (2) is a generalisation of (3) to the resourced semantics,
so the counter-example for (3) is the simpler and more educating:
\<close>

lemma counter_example:
  assumes "Equation (3)": "\<And> n d d'. \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>(d \<down>Fn d') = \<psi>\<^sup>D\<^bsub>Suc n\<^esub>\<cdot>d \<down>Fn \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d'"
  shows "False"
proof-
  define n :: nat where "n = 1"
  define d where "d = Fn\<cdot>(\<Lambda> e. (e \<down>Fn \<bottom>))"
  define d' where "d' = Fn\<cdot>(\<Lambda> _. Fn\<cdot>(\<Lambda> _. \<bottom>))"
  have "Fn\<cdot>(\<Lambda> _. \<bottom>) = \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>(d \<down>Fn d')"
    by (simp add: d_def d'_def n_def cfun_map_def)
  also
  have "\<dots> = \<psi>\<^sup>D\<^bsub>Suc n\<^esub>\<cdot>d \<down>Fn \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d'"
    using "Equation (3)".
  also have "\<dots> = \<bottom>"
    by (simp add: d_def d'_def n_def)
  finally show False by simp
qed

text \<open>
For completeness, and to avoid making false assertions, the counter-example to equation (2):
\<close>

lemma counter_example2:
  assumes "Equation (2)": "\<And> n e a c. \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>((e \<down>CFn a)\<cdot>c) = (\<psi>\<^sup>E\<^bsub>Suc n\<^esub>\<cdot>e \<down>CFn \<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>a)\<cdot>c"
  shows "False"
proof-
  define n :: nat where "n = 1"
  define e where "e = CFn\<cdot>(\<Lambda> e r. (e\<cdot>r \<down>CFn \<bottom>)\<cdot>r)"
  define a :: "C \<rightarrow> CValue" where "a = (\<Lambda> _ . CFn\<cdot>(\<Lambda> _ _. CFn\<cdot>(\<Lambda> _ _. \<bottom>)))"
  fix c :: C
  have "CFn\<cdot>(\<Lambda> _ _. \<bottom>) = \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>((e \<down>CFn a)\<cdot>c)"
    by (simp add: e_def a_def n_def cfun_map_def)
  also
  have "\<dots> = (\<psi>\<^sup>E\<^bsub>Suc n\<^esub>\<cdot>e \<down>CFn \<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>a)\<cdot>c"
    using "Equation (2)".
  also have "\<dots> = \<bottom>"
    by (simp add: e_def a_def n_def)
  finally show False by simp
qed

text \<open>A suitable substitute for the lemma can be found in 4.3.5 (1) in \cite{fullabstraction},
which in our setting becomes the following (note the extra invocation of @{term "Value_take n"} on
the left hand side):
\<close>

lemma "Abramsky 4,3,5 (1)":
  "\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>(d \<down>Fn \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d') = \<psi>\<^sup>D\<^bsub>Suc n\<^esub>\<cdot>d \<down>Fn \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d'"
  by (cases d) (auto simp add: Value.take_take)

text \<open>
The problematic equations are used in the proof of the only-if direction of proposition 9 in
\cite{functionspaces}. It can be fixed by applying take-induction, which inserts the
extra call to @{term "Value_take n"} in the right spot.
\<close>

subsubsection \<open>Working with @{typ Value} and @{typ CValue}\<close>

text \<open>Combined case distinguishing and induction rules.\<close>

lemma value_CValue_cases:
  obtains
  "x = \<bottom>" "y = \<bottom>" |
  f where "x = Fn\<cdot>f" "y = \<bottom>" |
  g where "x = \<bottom>" "y = CFn\<cdot>g" |
  f g where "x = Fn\<cdot>f" "y = CFn \<cdot> g" |
  b\<^sub>1 where "x = B\<cdot>(Discr b\<^sub>1)" "y = \<bottom>" |
  b\<^sub>1 g where "x = B\<cdot>(Discr b\<^sub>1)" "y = CFn\<cdot>g" |
  b\<^sub>1 b\<^sub>2 where "x = B\<cdot>(Discr b\<^sub>1)" "y = CB\<cdot>(Discr b\<^sub>2)" |
  f b\<^sub>2 where "x = Fn\<cdot>f" "y = CB\<cdot>(Discr b\<^sub>2)" |
  b\<^sub>2 where "x = \<bottom>" "y = CB\<cdot>(Discr b\<^sub>2)"
  by (metis CValue.exhaust Discr_undiscr Value.exhaust)

lemma Value_CValue_take_induct:
  assumes "adm (case_prod P)"
  assumes "\<And> n. P (\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x) (\<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>y)"
  shows "P x y"
proof-
  have "case_prod P (\<Squnion>n. (\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x, \<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>y))"
    by (rule admD[OF \<open>adm (case_prod P)\<close> ch2ch_Pair[OF ch2ch_Rep_cfunL[OF Value.chain_take] ch2ch_Rep_cfunL[OF C_to_CValue_chain_take]]])
       (simp add: assms(2))
  hence "case_prod P (x,y)"
    by (simp add: lub_Pair[OF ch2ch_Rep_cfunL[OF Value.chain_take] ch2ch_Rep_cfunL[OF C_to_CValue_chain_take]]
                  Value.reach C_to_CValue_reach)
  thus ?thesis by simp
qed

subsubsection \<open>Restricted similarity is defined recursively\<close>

text \<open>The base case\<close>

inductive similar'_base :: "Value \<Rightarrow> CValue \<Rightarrow> bool" where
  bot_similar'_base[simp,intro]: "similar'_base \<bottom> \<bottom>"

inductive_cases [elim!]:
   "similar'_base x y"

text \<open>The inductive case\<close>

inductive similar'_step :: "(Value \<Rightarrow> CValue \<Rightarrow> bool) \<Rightarrow> Value \<Rightarrow> CValue \<Rightarrow> bool" for s where
  bot_similar'_step[intro!]: "similar'_step s \<bottom> \<bottom>" |
  bool_similar'_step[intro]: "similar'_step s (B\<cdot>b) (CB\<cdot>b)" |
  Fun_similar'_step[intro]: "(\<And> x y . s x (y\<cdot>C\<^sup>\<infinity>) \<Longrightarrow> s (f\<cdot>x) (g\<cdot>y\<cdot>C\<^sup>\<infinity>)) \<Longrightarrow> similar'_step s (Fn\<cdot>f) (CFn\<cdot>g)"

inductive_cases [elim!]:
   "similar'_step s x \<bottom>"
   "similar'_step s \<bottom> y"
   "similar'_step s (B\<cdot>f) (CB\<cdot>g)"
   "similar'_step s (Fn\<cdot>f) (CFn\<cdot>g)"

text \<open>
We now create the restricted similarity relation, by primitive recursion over @{term n}.

This cannot be done using an inductive definition, as it would not be monotone.
\<close>

fun similar' where
 "similar' 0 = similar'_base" |
 "similar' (Suc n) = similar'_step (similar' n)"
declare similar'.simps[simp del]

abbreviation similar'_syn  ("_ \<triangleleft>\<triangleright>\<^bsub>_\<^esub> _" [50,50,50] 50)
  where "similar'_syn x n y \<equiv> similar' n x y"

lemma similar'_botI[intro!,simp]: "\<bottom> \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<bottom>"
  by (cases n) (auto simp add: similar'.simps)

lemma similar'_FnI[intro]:
  assumes "\<And>x y.  x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> y\<cdot>C\<^sup>\<infinity> \<Longrightarrow> f\<cdot>x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> g\<cdot>y\<cdot>C\<^sup>\<infinity>"
  shows "Fn\<cdot>f \<triangleleft>\<triangleright>\<^bsub>Suc n\<^esub> CFn\<cdot>g"
using assms by (auto simp add: similar'.simps)

lemma similar'_FnE[elim!]:
  assumes "Fn\<cdot>f \<triangleleft>\<triangleright>\<^bsub>Suc n\<^esub> CFn\<cdot>g"
  assumes "(\<And>x y.  x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> y\<cdot>C\<^sup>\<infinity> \<Longrightarrow> f\<cdot>x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> g\<cdot>y\<cdot>C\<^sup>\<infinity>) \<Longrightarrow> P"
  shows P
using assms by (auto simp add: similar'.simps)

lemma bot_or_not_bot':
  "x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> y \<Longrightarrow> (x = \<bottom> \<longleftrightarrow> y = \<bottom>)"
  by (cases n) (auto simp add: similar'.simps elim: similar'_base.cases similar'_step.cases)

lemma similar'_bot[elim_format, elim!]:
    "\<bottom> \<triangleleft>\<triangleright>\<^bsub>n\<^esub> x \<Longrightarrow> x = \<bottom>"
    "y \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<bottom> \<Longrightarrow> y = \<bottom>"
by (metis bot_or_not_bot')+

lemma similar'_typed[simp]:
  "\<not> B\<cdot>b \<triangleleft>\<triangleright>\<^bsub>n\<^esub> CFn\<cdot>g"
  "\<not> Fn\<cdot>f \<triangleleft>\<triangleright>\<^bsub>n\<^esub> CB\<cdot>b"
  by (cases n, auto simp add: similar'.simps elim: similar'_base.cases similar'_step.cases)+

lemma similar'_bool[simp]:
  "B\<cdot>b\<^sub>1 \<triangleleft>\<triangleright>\<^bsub>Suc n\<^esub> CB\<cdot>b\<^sub>2 \<longleftrightarrow> b\<^sub>1 = b\<^sub>2"
  by (auto simp add: similar'.simps elim: similar'_base.cases similar'_step.cases)

subsubsection \<open>Moving up and down the similarity relations\<close>

text \<open>
These correspond to Lemma 7 in |cite{functionspaces}.
\<close>

lemma similar'_down: "d \<triangleleft>\<triangleright>\<^bsub>Suc n\<^esub> e \<Longrightarrow> \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>e"
  and similar'_up: "d \<triangleleft>\<triangleright>\<^bsub>n\<^esub> e \<Longrightarrow> \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d \<triangleleft>\<triangleright>\<^bsub>Suc n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>e"
proof (induction n arbitrary: d e)
  case (Suc n) case 1 with  Suc
  show ?case
    by (cases d e rule:value_CValue_cases) auto
next
  case (Suc n) case 2 with Suc
  show ?case
    by (cases d e rule:value_CValue_cases) auto
qed auto

text \<open>
A generalisation of the above, doing multiple steps at once.
\<close>

lemma similar'_up_le: "n \<le> m \<Longrightarrow> \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>e \<Longrightarrow> \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d \<triangleleft>\<triangleright>\<^bsub>m\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>e"
  by (induction rule: dec_induct )
     (auto dest: similar'_up simp add: Value.take_take CValue.take_take min_absorb2)

lemma similar'_down_le: "n \<le> m \<Longrightarrow> \<psi>\<^sup>D\<^bsub>m\<^esub>\<cdot>d \<triangleleft>\<triangleright>\<^bsub>m\<^esub> \<psi>\<^sup>E\<^bsub>m\<^esub>\<cdot>e \<Longrightarrow> \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>e"
  by (induction rule: inc_induct )
     (auto dest: similar'_down simp add: Value.take_take CValue.take_take min_absorb1)

lemma similar'_take: "d \<triangleleft>\<triangleright>\<^bsub>n\<^esub> e \<Longrightarrow> \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>e"
  apply (drule similar'_up)
  apply (drule similar'_down)
  apply (simp add: Value.take_take CValue.take_take)
  done

subsubsection \<open>Admissibility\<close>

text \<open>
A technical prerequisite for induction is admissibility of the predicate, i.e.\ that the predicate
holds for the limit of a chain, given that it holds for all elements.
\<close>

lemma similar'_base_adm: "adm (\<lambda> x. similar'_base (fst x) (snd x))"
proof (rule admI, goal_cases)
  case (1 Y)
  then have "Y = (\<lambda> _ . \<bottom>)" by (metis prod.exhaust fst_eqD inst_prod_pcpo similar'_base.simps snd_eqD)
  thus ?case by auto
qed

lemma similar'_step_adm:
  assumes "adm (\<lambda> x. s (fst x) (snd x))"
  shows "adm (\<lambda> x. similar'_step s (fst x) (snd x))"
proof (rule admI, goal_cases)
  case prems: (1 Y)
  from \<open>chain Y\<close>
  have "chain (\<lambda> i. fst (Y i))" by (rule ch2ch_fst)
  thus ?case
  proof(cases rule: Value_chainE)
  case bot
    hence *: "\<And> i. fst (Y i) = \<bottom>" by metis
    with prems(2)[unfolded split_beta]
    have "\<And>i. snd (Y i) = \<bottom>" by auto
    hence "Y = (\<lambda> i. (\<bottom>, \<bottom>))" using * by (metis surjective_pairing)
    thus ?thesis by auto
  next
  case (B n b)
    hence "\<forall>i. fst (Y (i + n)) = B\<cdot>b" by (metis add.commute not_add_less1)
    with prems(2)
    have "\<forall>i. Y (i + n) = (B\<cdot>b, CB\<cdot>b)"
      apply auto
      apply (erule_tac x = "i + n" in allE)
      apply (erule_tac x = "i" in allE)
      apply (erule similar'_step.cases)
      apply auto
      by (metis fst_conv old.prod.exhaust snd_conv)
    hence "similar'_step s (fst (\<Squnion> i. Y (i + n))) (snd (\<Squnion> i. Y (i + n)))" by auto
    thus ?thesis
      by (simp add: lub_range_shift[OF \<open>chain Y\<close>])
  next
    fix n
    fix Y'
    assume "chain Y'" and "(\<lambda>i. fst (Y i)) = (\<lambda> m. (if m < n then \<bottom> else Fn\<cdot>(Y' (m-n))))"
    hence Y': "\<And> i. fst (Y (i+n)) = Fn\<cdot>(Y' i)" by (metis add_diff_cancel_right' not_add_less2)
    with prems(2)[unfolded split_beta]
    have "\<And>i. \<exists> g'. snd (Y (i+n)) = CFn\<cdot>g'"
      by -(erule_tac x = "i + n" in allE, auto elim!: similar'_step.cases)
    then obtain Y'' where Y'': "\<And> i. snd (Y (i+n)) = CFn\<cdot>(Y'' i)" by metis
    from prems(1) have "\<And>i. Y i \<sqsubseteq> Y (Suc i)"
      by (simp add: po_class.chain_def)
    then have *: "\<And>i. Y (i + n) \<sqsubseteq> Y (Suc i + n)"
      by simp
    have "chain Y''"
      apply (rule chainI)
      apply (rule iffD1[OF CValue.inverts(1)])
      apply (subst (1 2) Y''[symmetric])
      apply (rule snd_monofun)
      apply (rule *)
      done

    have "similar'_step s (Fn\<cdot>(\<Squnion> i. (Y' i))) (CFn \<cdot> (\<Squnion> i. Y'' i))"
    proof (rule Fun_similar'_step)
      fix x y
      from prems(2) Y' Y''
      have "\<And>i. similar'_step s (Fn\<cdot>(Y' i)) (CFn\<cdot>(Y'' i))" by metis
      moreover
      assume "s x (y\<cdot>C\<^sup>\<infinity>)"
      ultimately
      have "\<And>i. s (Y' i\<cdot>x) (Y'' i\<cdot>y\<cdot>C\<^sup>\<infinity>)" by auto
      hence "case_prod s (\<Squnion> i. ((Y' i)\<cdot>x, (Y'' i)\<cdot>y\<cdot>C\<^sup>\<infinity>))"
        apply -
        apply (rule admD[OF adm_case_prod[where P = "\<lambda>_ . s", OF assms]])
        apply (simp add:  \<open>chain Y'\<close>  \<open>chain Y''\<close>)
        apply simp
        done
      thus "s ((\<Squnion> i. Y' i)\<cdot>x) ((\<Squnion> i. Y'' i)\<cdot>y\<cdot>C\<^sup>\<infinity>)"
        by (simp add: lub_Pair  ch2ch_Rep_cfunL contlub_cfun_fun  \<open>chain Y'\<close>  \<open>chain Y''\<close>)
    qed
    hence "similar'_step s (fst (\<Squnion> i. Y (i+n))) (snd (\<Squnion> i. Y (i+n)))"
      by (simp add: Y' Y''
          cont2contlubE[OF cont_fst chain_shift[OF prems(1)]]  cont2contlubE[OF cont_snd chain_shift[OF prems(1)]]
           contlub_cfun_arg[OF \<open>chain Y''\<close>] contlub_cfun_arg[OF \<open>chain Y'\<close>])
    thus "similar'_step s (fst (\<Squnion> i. Y i)) (snd (\<Squnion> i. Y i))"
      by (simp add: lub_range_shift[OF \<open>chain Y\<close>])
  qed
qed

lemma similar'_adm: "adm (\<lambda>x. fst x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> snd x)"
  by (induct n) (auto simp add: similar'.simps intro: similar'_base_adm similar'_step_adm)

lemma similar'_admI: "cont f \<Longrightarrow> cont g \<Longrightarrow> adm (\<lambda>x. f x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> g x)"
  by (rule adm_subst[OF _ similar'_adm, where t = "\<lambda>x. (f x, g x)", simplified]) auto

subsubsection \<open>The real similarity relation\<close>

text \<open>
This is the goal of the theory: A relation between @{typ Value} and @{typ CValue}.
\<close>

definition similar :: "Value \<Rightarrow> CValue \<Rightarrow> bool" (infix "\<triangleleft>\<triangleright>" 50) where
  "x \<triangleleft>\<triangleright> y \<longleftrightarrow> (\<forall>n. \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>y)"

lemma similarI:
  "(\<And> n. \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>y) \<Longrightarrow> x \<triangleleft>\<triangleright> y"
  unfolding similar_def by blast

lemma similarE:
  "x \<triangleleft>\<triangleright> y \<Longrightarrow> \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>y"
  unfolding similar_def by blast

lemma similar_bool[simp]: "B\<cdot>b \<triangleleft>\<triangleright> CB\<cdot>b"
  by (rule similarI, case_tac n, auto)

lemma [elim_format, elim!]: "x \<triangleleft>\<triangleright> \<bottom> \<Longrightarrow> x = \<bottom>"
  unfolding similar_def
  apply (cases x)
  apply auto
  apply (erule_tac x = "Suc 0" in allE, auto)+
  done

lemma [elim_format, elim!]: "x \<triangleleft>\<triangleright> CB\<cdot>b \<Longrightarrow> x = B\<cdot>b"
  unfolding similar_def
  apply (cases x)
  apply auto
  apply (erule_tac x = "Suc 0" in allE, auto)+
  done

lemma [elim_format, elim!]: "\<bottom> \<triangleleft>\<triangleright> y \<Longrightarrow> y = \<bottom>"
  unfolding similar_def
  apply (cases y)
  apply auto
  apply (erule_tac x = "Suc 0" in allE, auto)+
  done

lemma [elim_format, elim!]: "B\<cdot>b \<triangleleft>\<triangleright> y \<Longrightarrow> y = CB\<cdot>b"
  unfolding similar_def
  apply (cases y)
  apply auto
  apply (erule_tac x = "Suc 0" in allE, auto)+
  done

lemma take_similar'_similar:
  assumes "x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> y"
  shows  "\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x \<triangleleft>\<triangleright> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>y"
proof(rule similarI)
  fix m
  from assms
  have "\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>y" by (rule similar'_take)
  moreover
  have "n \<le> m \<or> m \<le> n" by auto
  ultimately
  show "\<psi>\<^sup>D\<^bsub>m\<^esub>\<cdot>(\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x) \<triangleleft>\<triangleright>\<^bsub>m\<^esub> \<psi>\<^sup>E\<^bsub>m\<^esub>\<cdot>(\<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>y)"
    by (auto elim: similar'_up_le similar'_down_le dest: similar'_take
        simp add: min_absorb2 min_absorb1 Value.take_take CValue.take_take)
qed

lemma bot_or_not_bot:
  "x \<triangleleft>\<triangleright> y \<Longrightarrow> (x = \<bottom> \<longleftrightarrow> y = \<bottom>)"
  by (cases x y rule:value_CValue_cases) auto

lemma bool_or_not_bool:
  "x \<triangleleft>\<triangleright> y \<Longrightarrow> (x = B\<cdot>b) \<longleftrightarrow> (y = CB\<cdot>b)"
  by (cases x y rule:value_CValue_cases) auto

lemma slimilar_bot_cases[consumes 1, case_names bot bool Fn]:
  assumes "x \<triangleleft>\<triangleright> y"
  obtains "x = \<bottom>" "y = \<bottom>" |
  b where "x = B\<cdot>(Discr b)" "y = CB\<cdot>(Discr b)" |
  f g where "x = Fn\<cdot>f" "y = CFn \<cdot> g"
using assms
by (metis CValue.exhaust Value.exhaust bool_or_not_bool bot_or_not_bot discr.exhaust)

lemma similar_adm: "adm (\<lambda>x. fst x \<triangleleft>\<triangleright> snd x)"
  unfolding similar_def
  by (intro adm_lemmas similar'_admI cont2cont)

lemma similar_admI: "cont f \<Longrightarrow> cont g \<Longrightarrow> adm (\<lambda>x. f x \<triangleleft>\<triangleright> g x)"
  by (rule adm_subst[OF _ similar_adm, where t = "\<lambda>x. (f x, g x)", simplified]) auto

text \<open>
Having constructed the relation we can how show that it indeed is the desired relation,
relating $|bot$ with $|bot$ and functions with functions, if they take related arguments to related values.
This corresponds to Proposition 9 in |cite{functionspaces}.
\<close>

lemma similar_nice_def: "x \<triangleleft>\<triangleright> y \<longleftrightarrow> (x = \<bottom> \<and> y = \<bottom> \<or> (\<exists> b. x = B\<cdot>(Discr b) \<and> y = CB\<cdot>(Discr b)) \<or> (\<exists> f g. x = Fn\<cdot>f \<and> y = CFn\<cdot>g \<and> (\<forall> a b. a \<triangleleft>\<triangleright> b\<cdot>C\<^sup>\<infinity> \<longrightarrow> f\<cdot>a \<triangleleft>\<triangleright> g\<cdot>b\<cdot>C\<^sup>\<infinity>)))"
  (is "?L \<longleftrightarrow> ?R")
proof
  assume "?L"
  thus "?R"
  proof (cases x y rule:slimilar_bot_cases)
    case bot thus ?thesis by simp
  next
    case bool thus ?thesis by simp
  next
    case (Fn f g)
    note \<open>?L\<close>[unfolded Fn]
    have "\<forall>a b. a \<triangleleft>\<triangleright> b\<cdot>C\<^sup>\<infinity> \<longrightarrow> f\<cdot>a \<triangleleft>\<triangleright> g\<cdot>b\<cdot>C\<^sup>\<infinity>"
    proof(intro impI allI)
      fix a b
      assume "a \<triangleleft>\<triangleright> b\<cdot>C\<^sup>\<infinity>"

      show "f\<cdot>a \<triangleleft>\<triangleright> g\<cdot>b\<cdot>C\<^sup>\<infinity>"
      proof(rule similarI)
        fix n
        have "adm (\<lambda>(b, a). \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>(f\<cdot>b) \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>(g\<cdot>a\<cdot>C\<^sup>\<infinity>))"
          by (intro adm_case_prod similar'_admI cont2cont)
        thus "\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>(f\<cdot>a) \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>(g\<cdot>b\<cdot>C\<^sup>\<infinity>)"
        proof (induct a b rule: Value_CValue_take_induct[consumes 1])
          txt \<open>This take induction is required to avoid the wrong equation shown above.\<close>
          fix m

          from \<open>a \<triangleleft>\<triangleright> b\<cdot>C\<^sup>\<infinity>\<close>
          have "\<psi>\<^sup>D\<^bsub>m\<^esub>\<cdot>a \<triangleleft>\<triangleright>\<^bsub>m\<^esub> \<psi>\<^sup>E\<^bsub>m\<^esub>\<cdot>(b\<cdot>C\<^sup>\<infinity>)" by (rule similarE)
          hence "\<psi>\<^sup>D\<^bsub>m\<^esub>\<cdot>a \<triangleleft>\<triangleright>\<^bsub>max m n\<^esub> \<psi>\<^sup>E\<^bsub>m\<^esub>\<cdot>(b\<cdot>C\<^sup>\<infinity>)" by (rule similar'_up_le[rotated]) auto
          moreover
          from \<open>Fn\<cdot>f \<triangleleft>\<triangleright> CFn\<cdot>g\<close>
          have "\<psi>\<^sup>D\<^bsub>Suc (max m n)\<^esub>\<cdot>(Fn\<cdot>f) \<triangleleft>\<triangleright>\<^bsub>Suc (max m n)\<^esub> \<psi>\<^sup>E\<^bsub>Suc (max m n)\<^esub>\<cdot>(CFn\<cdot>g)" by (rule similarE)
          ultimately
          have "\<psi>\<^sup>D\<^bsub>max m n\<^esub>\<cdot>(f\<cdot>(\<psi>\<^sup>D\<^bsub>max m n\<^esub>\<cdot>(\<psi>\<^sup>D\<^bsub>m\<^esub>\<cdot>a))) \<triangleleft>\<triangleright>\<^bsub>max m n\<^esub> \<psi>\<^sup>E\<^bsub>max m n\<^esub>\<cdot>(g\<cdot>(\<psi>\<^sup>A\<^bsub>max m n\<^esub>\<cdot>(\<psi>\<^sup>A\<^bsub>m\<^esub>\<cdot>b))\<cdot>C\<^sup>\<infinity>)"
            by auto
          hence " \<psi>\<^sup>D\<^bsub>max m n\<^esub>\<cdot>(f\<cdot>(\<psi>\<^sup>D\<^bsub>m\<^esub>\<cdot>a)) \<triangleleft>\<triangleright>\<^bsub>max m n\<^esub> \<psi>\<^sup>E\<^bsub>max m n\<^esub>\<cdot>(g\<cdot>(\<psi>\<^sup>A\<^bsub>m\<^esub>\<cdot>b)\<cdot>C\<^sup>\<infinity>)"
            by (simp add: Value.take_take cfun_map_map CValue.take_take ID_def eta_cfun min_absorb2 min_absorb1)
          thus "\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>(f\<cdot>(\<psi>\<^sup>D\<^bsub>m\<^esub>\<cdot>a)) \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>(g\<cdot>(\<psi>\<^sup>A\<^bsub>m\<^esub>\<cdot>b)\<cdot>C\<^sup>\<infinity>)"
            by (rule similar'_down_le[rotated]) auto
        qed
      qed
    qed
    thus ?thesis unfolding Fn by simp
  qed
next
  assume "?R"
  thus "?L"
  proof(elim conjE disjE exE ssubst)
    show "\<bottom> \<triangleleft>\<triangleright> \<bottom>" by simp
  next
    fix b
    show "B\<cdot>(Discr b) \<triangleleft>\<triangleright> CB\<cdot>(Discr b)" by simp
  next
    fix f g
    assume imp: "\<forall>a b. a \<triangleleft>\<triangleright> b\<cdot>C\<^sup>\<infinity> \<longrightarrow> f\<cdot>a \<triangleleft>\<triangleright> g\<cdot>b\<cdot>C\<^sup>\<infinity>"
    show "Fn\<cdot>f \<triangleleft>\<triangleright> CFn\<cdot>g"
    proof (rule similarI)
      fix n
      show "\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>(Fn\<cdot>f) \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>(CFn\<cdot>g)"
      proof(cases n)
        case 0 thus ?thesis by simp
      next
        case (Suc n)
        { fix x y
          assume "x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> y\<cdot>C\<^sup>\<infinity>"
          hence "\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x \<triangleleft>\<triangleright> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>(y\<cdot>C\<^sup>\<infinity>)" by (rule take_similar'_similar)
          hence "f\<cdot>(\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x) \<triangleleft>\<triangleright> g\<cdot>(\<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>y)\<cdot>C\<^sup>\<infinity>" using imp by auto
          hence "\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>(f\<cdot>(\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x)) \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>(g\<cdot>(\<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>y)\<cdot>C\<^sup>\<infinity>)"
            by (rule similarE)
        }
        with Suc
        show ?thesis by auto
      qed
    qed
  qed
qed

lemma similar_FnI[intro]:
  assumes "\<And>x y.  x \<triangleleft>\<triangleright> y\<cdot>C\<^sup>\<infinity> \<Longrightarrow> f\<cdot>x \<triangleleft>\<triangleright> g\<cdot>y\<cdot>C\<^sup>\<infinity>"
  shows "Fn\<cdot>f \<triangleleft>\<triangleright> CFn\<cdot>g"
by (metis assms similar_nice_def)

lemma similar_FnD[elim!]:
  assumes "Fn\<cdot>f \<triangleleft>\<triangleright> CFn\<cdot>g"
  assumes "x \<triangleleft>\<triangleright> y\<cdot>C\<^sup>\<infinity>"
  shows "f\<cdot>x \<triangleleft>\<triangleright> g\<cdot>y\<cdot>C\<^sup>\<infinity>"
using assms
by (subst (asm) similar_nice_def) auto

lemma similar_FnE[elim!]:
  assumes "Fn\<cdot>f \<triangleleft>\<triangleright> CFn\<cdot>g"
  assumes "(\<And>x y.  x \<triangleleft>\<triangleright> y\<cdot>C\<^sup>\<infinity> \<Longrightarrow> f\<cdot>x \<triangleleft>\<triangleright> g\<cdot>y\<cdot>C\<^sup>\<infinity>) \<Longrightarrow> P"
  shows P
by (metis assms similar_FnD)

subsubsection \<open>The similarity relation lifted pointwise to functions.\<close>

abbreviation fun_similar :: "('a::type \<Rightarrow> Value) \<Rightarrow> ('a \<Rightarrow> (C \<rightarrow> CValue)) \<Rightarrow> bool"  (infix "\<triangleleft>\<triangleright>\<^sup>*" 50) where
  "fun_similar \<equiv> pointwise (\<lambda>x y. x \<triangleleft>\<triangleright> y\<cdot>C\<^sup>\<infinity>)"

lemma fun_similar_fmap_bottom[simp]: "\<bottom> \<triangleleft>\<triangleright>\<^sup>* \<bottom>"
  by auto

lemma fun_similarE[elim]:
  assumes "m \<triangleleft>\<triangleright>\<^sup>* m'"
  assumes "(\<And>x. (m  x) \<triangleleft>\<triangleright> (m' x)\<cdot>C\<^sup>\<infinity>) \<Longrightarrow> Q"
  shows Q
  using assms unfolding pointwise_def by blast

end


chapter \<open>Wellformedness of patterns\<close>

theory Pats
imports Term
begin

text \<open>
  The @{class term} class already defines a generic definition of \<^emph>\<open>matching\<close> a \<^emph>\<open>pattern\<close> with a
  term. Importantly, the type of patterns is neither generic, nor a dedicated pattern type; instead,
  it is @{typ term} itself.

  Patterns are a proper subset of terms, with the restriction that no abstractions may occur and
  there must be at most a single occurrence of any variable (usually known as \<^emph>\<open>linearity\<close>).
  The first restriction can be modelled in a datatype, the second cannot. Consequently, I define a
  predicate that captures both properties.

  Using linearity, many more generic properties can be proved, for example that substituting the
  environment produced by matching yields the matched term.
\<close>

fun linear :: "term \<Rightarrow> bool" where
"linear (Free _) \<longleftrightarrow> True" |
"linear (Const _) \<longleftrightarrow> True" |
"linear (t\<^sub>1 $ t\<^sub>2) \<longleftrightarrow> linear t\<^sub>1 \<and> linear t\<^sub>2 \<and> \<not> is_free t\<^sub>1 \<and> fdisjnt (frees t\<^sub>1) (frees t\<^sub>2)" |
"linear _ \<longleftrightarrow> False"

lemmas linear_simps[simp] =
  linear.simps(2)[folded const_term_def]
  linear.simps(3)[folded app_term_def]

lemma linear_implies_no_abs: "linear t \<Longrightarrow> no_abs t"
proof induction
  case Const
  then show ?case
    by (fold const_term_def free_term_def app_term_def) auto
next
  case Free
  then show ?case
    by (fold const_term_def free_term_def app_term_def) auto
next
  case App
  then show ?case
    by (fold const_term_def free_term_def app_term_def) auto
qed auto

fun linears :: "term list \<Rightarrow> bool" where
"linears [] \<longleftrightarrow> True" |
"linears (t # ts) \<longleftrightarrow> linear t \<and> fdisjnt (frees t) (freess ts) \<and> linears ts"

lemma linears_butlastI[intro]: "linears ts \<Longrightarrow> linears (butlast ts)"
proof (induction ts)
  case (Cons t ts)
  hence "linear t" "linears (butlast ts)"
    by simp+
  moreover have " fdisjnt (frees t) (freess (butlast ts))"
    proof (rule fdisjnt_subset_right)
      show "freess (butlast ts) |\<subseteq>| freess ts"
        by (rule freess_subset) (auto dest: in_set_butlastD)
    next
      show "fdisjnt (frees t) (freess ts)"
        using Cons by simp
    qed
  ultimately show ?case
    by simp
qed simp

lemma linears_appI[intro]:
  assumes "linears xs" "linears ys" "fdisjnt (freess xs) (freess ys)"
  shows "linears (xs @ ys)"
using assms proof (induction xs)
  case (Cons z zs)
  hence "linears zs"
    by simp+

  have "fdisjnt (frees z) (freess zs |\<union>| freess ys)"
    proof (rule fdisjnt_union_right)
      show "fdisjnt (frees z) (freess zs)"
        using \<open>linears (z # zs)\<close> by simp
    next
      have "frees z |\<subseteq>| freess (z # zs)"
        unfolding freess_def by simp
      thus "fdisjnt (frees z) (freess ys)"
        by (rule fdisjnt_subset_left) fact
    qed

  moreover have "linears (zs @ ys)"
    proof (rule Cons)
      show "fdisjnt (freess zs) (freess ys)"
        using Cons
        by (auto intro: freess_subset fdisjnt_subset_left)
    qed fact+

  ultimately show ?case
    using Cons by auto
qed simp

lemma linears_linear: "linears ts \<Longrightarrow> t \<in> set ts \<Longrightarrow> linear t"
by (induct ts) auto

lemma linears_singleI[intro]: "linear t \<Longrightarrow> linears [t]"
by (simp add: freess_def fdisjnt_alt_def)

lemma linear_strip_comb: "linear t \<Longrightarrow> linear (fst (strip_comb t))"
by (induction t rule: strip_comb_induct) (auto simp: split_beta)

lemma linears_strip_comb: "linear t \<Longrightarrow> linears (snd (strip_comb t))"
proof (induction t rule: strip_comb_induct)
  case (app t\<^sub>1 t\<^sub>2)
  have "linears (snd (strip_comb t\<^sub>1) @ [t\<^sub>2])"
    proof (intro linears_appI linears_singleI)
      have "freess (snd (strip_comb t\<^sub>1)) |\<subseteq>| frees t\<^sub>1"
        by (subst frees_strip_comb) auto
      moreover have "fdisjnt (frees t\<^sub>1) (frees t\<^sub>2)"
        using app by auto
      ultimately have "fdisjnt (freess (snd (strip_comb t\<^sub>1))) (frees t\<^sub>2)"
        by (rule fdisjnt_subset_left)
      thus "fdisjnt (freess (snd (strip_comb t\<^sub>1))) (freess [t\<^sub>2])"
        by simp
    next
      show "linear t\<^sub>2" "linears (snd (strip_comb t\<^sub>1))"
        using app by auto
    qed
  thus ?case
    by (simp add: split_beta)
qed auto

lemma linears_appendD:
  assumes "linears (xs @ ys)"
  shows "linears xs" "linears ys" "fdisjnt (freess xs) (freess ys)"
using assms proof (induction xs)
  case (Cons x xs)
  assume "linears ((x # xs) @ ys)"

  hence "linears (x # (xs @ ys))"
    by simp
  hence "linears (xs @ ys)" "linear x" "fdisjnt (frees x) (freess (xs @ ys))"
    by auto
  hence "linears xs"
    using Cons by simp
  moreover have "fdisjnt (frees x) (freess xs)"
    proof (rule fdisjnt_subset_right)
      show "freess xs |\<subseteq>| freess (xs @ ys)" by simp
    qed fact
  ultimately show "linears (x # xs)"
    using \<open>linear x\<close> by auto

  have "fdisjnt (freess xs) (freess ys)"
    by (rule Cons) fact
  moreover have "fdisjnt (frees x) (freess ys)"
    proof (rule fdisjnt_subset_right)
      show "freess ys |\<subseteq>| freess (xs @ ys)" by simp
    qed fact
  ultimately show "fdisjnt (freess (x # xs)) (freess ys)"
    unfolding fdisjnt_alt_def
    by auto
qed (auto simp: fdisjnt_alt_def)

lemma linear_list_comb:
  assumes "linear f" "linears xs" "fdisjnt (frees f) (freess xs)" "\<not> is_free f"
  shows "linear (list_comb f xs)"
using assms
proof (induction xs arbitrary: f)
  case (Cons x xs)

  hence *: "fdisjnt (frees f) (frees x |\<union>| freess xs)"
    by simp

  have "linear (list_comb (f $ x) xs)"
    proof (rule Cons)
      have "linear x"
        using Cons by simp
      moreover have "fdisjnt (frees f) (frees x)"
        using * by (auto intro: fdisjnt_subset_right)
      ultimately show "linear (f $ x)"
        using assms Cons by simp
    next
      show "linears xs"
        using Cons by simp
    next
      have "fdisjnt (frees f) (freess xs)"
        using * by (auto intro: fdisjnt_subset_right)
      moreover have "fdisjnt (frees x) (freess xs)"
        using Cons by simp
      ultimately show "fdisjnt (frees (f $ x)) (freess xs)"
        by (auto intro: fdisjnt_union_left)
    qed auto
  thus ?case
    by (simp add: app_term_def)
qed auto

corollary linear_list_comb': "linears xs \<Longrightarrow> linear (name $$ xs)"
by (auto intro: linear_list_comb simp: fdisjnt_alt_def)

lemma linear_strip_comb_cases[consumes 1]:
  assumes "linear pat"
  obtains (comb) s args where "strip_comb pat = (Const s, args)" "pat = s $$ args"
        | (free) s where "strip_comb pat = (Free s, [])" "pat = Free s"
using assms
proof (induction pat rule: strip_comb_induct)
  case (app t\<^sub>1 t\<^sub>2)
  show ?case
    proof (rule "app.IH")
      show "linear t\<^sub>1"
        using app by simp
    next
      fix s
      assume "strip_comb t\<^sub>1 = (Free s, [])"
      hence "t\<^sub>1 = Free s"
        by (metis fst_conv snd_conv strip_comb_empty)
      hence False
        using app by simp
      thus thesis
        by simp
    next
      fix s args
      assume "strip_comb t\<^sub>1 = (Const s, args)"
      with app show thesis
        by (fastforce simp add: strip_comb_app)
    qed
next
  case (no_app t)
  thus ?case
    by (cases t) (auto simp: const_term_def)
qed

lemma wellformed_linearI: "linear t \<Longrightarrow> wellformed' n t"
by (induct t) auto

lemma pat_cases:
  obtains (free) s where "t = Free s"
        | (comb) name args where "linears args" "t = name $$ args"
        | (nonlinear) "\<not> linear t"
proof (cases t)
  case Free
  thus thesis using free by simp
next
  case Bound
  thus thesis using nonlinear by simp
next
  case Abs
  thus thesis using nonlinear by simp
next
  case (Const name)
  have "linears []" by simp
  moreover have "t = name $$ []" unfolding Const by (simp add: const_term_def)
  ultimately show thesis
    by (rule comb)
next
  case (App u v)
  show thesis
    proof (cases "linear t")
      case False
      thus thesis using nonlinear by simp
    next
      case True
      thus thesis
        proof (cases rule: linear_strip_comb_cases)
          case free
          thus thesis using that by simp
        next
          case (comb name args)
          moreover hence "linears (snd (strip_comb t))"
            using True by (blast intro: linears_strip_comb)
          ultimately have "linears args"
            by simp
          thus thesis using that comb by simp
        qed
    qed
qed

corollary linear_pat_cases[consumes 1]:
  assumes "linear t"
  obtains (free) s where "t = Free s"
        | (comb) name args where "linears args" "t = name $$ args"
using assms
by (metis pat_cases)

lemma linear_pat_induct[consumes 1, case_names free comb]:
  assumes "linear t"
  assumes "\<And>s. P (Free s)"
  assumes "\<And>name args. linears args \<Longrightarrow> (\<And>arg. arg \<in> set args \<Longrightarrow> P arg) \<Longrightarrow> P (name $$ args)"
  shows "P t"
using wf_measure[of size] \<open>linear t\<close>
proof (induction t)
  case (less t)

  show ?case
    using \<open>linear t\<close>
    proof (cases rule: linear_pat_cases)
      case (free name)
      thus ?thesis
        using assms by simp
    next
      case (comb name args)
      show ?thesis
        proof (cases "args = []")
          case True
          thus ?thesis
            using assms comb by fastforce
        next
          case False
          show ?thesis
            unfolding \<open>t = _\<close>
            proof (rule assms)
              fix arg
              assume "arg \<in> set args"

              then have "(arg, t) \<in> measure size"
                unfolding \<open>t = _\<close>
                by (induction args) auto

              moreover have "linear arg"
                using \<open>arg \<in> set args\<close> \<open>linears args\<close>
                by (auto dest: linears_linear)

              ultimately show "P arg"
                using less by auto
            qed fact
        qed
    qed
qed

context begin

private lemma match_subst_correctness0:
  assumes "linear t"
  shows "case match t u of
          None \<Rightarrow> (\<forall>env. subst (convert_term t) env \<noteq> u) |
          Some env \<Rightarrow> subst (convert_term t) env = u"
using assms proof (induction t arbitrary: u)
  case Free
  show ?case
    unfolding match.simps
    by (fold free_term_def) auto
next
  case Const
  show ?case
    unfolding match.simps
    by (fold const_term_def) (auto split: option.splits)
next
  case (App t\<^sub>1 t\<^sub>2)
  hence linear: "linear t\<^sub>1" "linear t\<^sub>2" "fdisjnt (frees t\<^sub>1) (frees t\<^sub>2)"
    by simp+

  show ?case
    proof (cases "unapp u")
      case None
      then show ?thesis
        apply simp
        apply (fold app_term_def)
        apply simp
        using app_simps(3) is_app_def by blast
    next
      case (Some u')
      then obtain u\<^sub>1 u\<^sub>2 where u: "unapp u = Some (u\<^sub>1, u\<^sub>2)" by (cases u') auto
      hence "u = app u\<^sub>1 u\<^sub>2" by auto

      note 1 = App(1)[OF \<open>linear t\<^sub>1\<close>, of u\<^sub>1]
      note 2 = App(2)[OF \<open>linear t\<^sub>2\<close>, of u\<^sub>2]

      show ?thesis
        proof (cases "match t\<^sub>1 u\<^sub>1")
          case None
          then show ?thesis
            using u
            apply simp
            apply (fold app_term_def)
            using 1 by auto
        next
          case (Some env\<^sub>1)
          with 1 have s1: "subst (convert_term t\<^sub>1) env\<^sub>1 = u\<^sub>1" by simp
          show ?thesis
            proof (cases "match t\<^sub>2 u\<^sub>2")
              case None
              then show ?thesis
                using u
                apply simp
                apply (fold app_term_def)
                using 2 by auto
            next
              case (Some env\<^sub>2)
              with 2 have s2: "subst (convert_term t\<^sub>2) env\<^sub>2 = u\<^sub>2" by simp

              note match = \<open>match t\<^sub>1 u\<^sub>1 = Some env\<^sub>1\<close> \<open>match t\<^sub>2 u\<^sub>2 = Some env\<^sub>2\<close>

              let ?env = "env\<^sub>1 ++\<^sub>f env\<^sub>2"
              from match have "frees t\<^sub>1 = fmdom env\<^sub>1" "frees t\<^sub>2 = fmdom env\<^sub>2"
                by (auto simp: match_dom)
              with linear have "env\<^sub>1 = fmrestrict_fset (frees t\<^sub>1) ?env" "env\<^sub>2 = fmrestrict_fset (frees t\<^sub>2) ?env"
                apply auto
                apply (auto simp: fmfilter_alt_defs)
                apply (subst fmfilter_false; auto simp: fdisjnt_alt_def intro: fmdomI)+
                done
              with s1 s2 have "subst (convert_term t\<^sub>1) ?env = u\<^sub>1" "subst (convert_term t\<^sub>2) ?env = u\<^sub>2"
                using linear
                by (metis subst_restrict' convert_term_frees linear_implies_no_abs)+

              then show ?thesis
                using match unfolding \<open>u = _\<close>
                apply simp
                apply (fold app_term_def)
                by simp
            qed
        qed
    qed
qed auto

lemma match_subst_some[simp]:
  "match t u = Some env \<Longrightarrow> linear t \<Longrightarrow> subst (convert_term t) env = u"
by (metis (mono_tags) match_subst_correctness0 option.simps(5))

lemma match_subst_none:
  "match t u = None \<Longrightarrow> linear t \<Longrightarrow> subst (convert_term t) env = u \<Longrightarrow> False"
by (metis (mono_tags, lifting) match_subst_correctness0 option.simps(4))

end

(* FIXME inverse direction? *)

lemma match_matches: "match t u = Some env \<Longrightarrow> linear t \<Longrightarrow> t \<lesssim> u"
by (metis match_subst_some linear_implies_no_abs convert_term_id matchesI)

lemma overlapping_var1I: "overlapping (Free name) t"
proof (intro overlappingI matchesI)
  show "subst (Free name) (fmap_of_list [(name, t)]) = t"
    by simp
next
  show "subst t fmempty = t"
    by simp
qed

lemma overlapping_var2I: "overlapping t (Free name)"
proof (intro overlappingI matchesI)
  show "subst (Free name) (fmap_of_list [(name, t)]) = t"
    by simp
next
  show "subst t fmempty = t"
    by simp
qed

lemma non_overlapping_appI1: "non_overlapping t\<^sub>1 u\<^sub>1 \<Longrightarrow> non_overlapping (t\<^sub>1 $ t\<^sub>2) (u\<^sub>1 $ u\<^sub>2)"
unfolding overlapping_def matches_def by auto

lemma non_overlapping_appI2: "non_overlapping t\<^sub>2 u\<^sub>2 \<Longrightarrow> non_overlapping (t\<^sub>1 $ t\<^sub>2) (u\<^sub>1 $ u\<^sub>2)"
unfolding overlapping_def matches_def by auto

lemma non_overlapping_app_constI: "non_overlapping (t\<^sub>1 $ t\<^sub>2) (Const name)"
unfolding overlapping_def matches_def by simp

lemma non_overlapping_const_appI: "non_overlapping (Const name) (t\<^sub>1 $ t\<^sub>2)"
unfolding overlapping_def matches_def by simp

lemma non_overlapping_const_constI: "x \<noteq> y \<Longrightarrow> non_overlapping (Const x) (Const y)"
unfolding overlapping_def matches_def by simp

lemma match_overlapping:
  assumes "linear t\<^sub>1" "linear t\<^sub>2"
  assumes "match t\<^sub>1 u = Some env\<^sub>1" "match t\<^sub>2 u = Some env\<^sub>2"
  shows "overlapping t\<^sub>1 t\<^sub>2"
proof -
  define env\<^sub>1' where "env\<^sub>1' = (fmmap convert_term env\<^sub>1 :: (name, term) fmap)"
  define env\<^sub>2' where "env\<^sub>2' = (fmmap convert_term env\<^sub>2 :: (name, term) fmap)"
  from assms have "match t\<^sub>1 (convert_term u :: term) = Some env\<^sub>1'" "match t\<^sub>2 (convert_term u :: term) = Some env\<^sub>2'"
    unfolding env\<^sub>1'_def env\<^sub>2'_def
    by (metis convert_term_match)+
  with assms show ?thesis
    by (metis overlappingI match_matches)
qed

end