(*  Title:      HOL/Library/Z2.thy
    Author:     Brian Huffman
*)

section \<open>The Field of Integers mod 2\<close>

theory Z2
imports MainRLT
begin

text \<open>
  Note that in most cases \<^typ>\<open>bool\<close> is appropriate when a binary type is needed; the
  type provided here, for historical reasons named \<^text>\<open>bit\<close>, is only needed if proper
  field operations are required.
\<close>

typedef bit = \<open>UNIV :: bool set\<close> ..

instantiation bit :: zero_neq_one
begin

definition zero_bit :: bit
  where \<open>0 = Abs_bit False\<close>

definition one_bit :: bit
  where \<open>1 = Abs_bit True\<close>

instance
  by standard (simp add: zero_bit_def one_bit_def Abs_bit_inject)

end

free_constructors case_bit for \<open>0::bit\<close> | \<open>1::bit\<close>
proof -
  fix P :: bool
  fix a :: bit
  assume \<open>a = 0 \<Longrightarrow> P\<close> and \<open>a = 1 \<Longrightarrow> P\<close>
  then show P
    by (cases a) (auto simp add: zero_bit_def one_bit_def Abs_bit_inject)
qed simp

lemma bit_not_zero_iff [simp]:
  \<open>a \<noteq> 0 \<longleftrightarrow> a = 1\<close> for a :: bit
  by (cases a) simp_all

lemma bit_not_one_iff [simp]:
  \<open>a \<noteq> 1 \<longleftrightarrow> a = 0\<close> for a :: bit
  by (cases a) simp_all

instantiation bit :: semidom_modulo
begin

definition plus_bit :: \<open>bit \<Rightarrow> bit \<Rightarrow> bit\<close>
  where \<open>a + b = Abs_bit (Rep_bit a \<noteq> Rep_bit b)\<close>

definition minus_bit :: \<open>bit \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>minus_bit = plus\<close>

definition times_bit :: \<open>bit \<Rightarrow> bit \<Rightarrow> bit\<close>
  where \<open>a * b = Abs_bit (Rep_bit a \<and> Rep_bit b)\<close>

definition divide_bit :: \<open>bit \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>divide_bit = times\<close>

definition modulo_bit :: \<open>bit \<Rightarrow> bit \<Rightarrow> bit\<close>
  where \<open>a mod b = Abs_bit (Rep_bit a \<and> \<not> Rep_bit b)\<close>

instance
  by standard
    (auto simp flip: Rep_bit_inject
    simp add: zero_bit_def one_bit_def plus_bit_def times_bit_def modulo_bit_def Abs_bit_inverse Rep_bit_inverse)

end

lemma bit_2_eq_0 [simp]:
  \<open>2 = (0::bit)\<close>
  by (simp flip: one_add_one add: zero_bit_def plus_bit_def)

instance bit :: semiring_parity
  apply standard
    apply (auto simp flip: Rep_bit_inject simp add: modulo_bit_def Abs_bit_inverse Rep_bit_inverse)
         apply (auto simp add: zero_bit_def one_bit_def Abs_bit_inverse Rep_bit_inverse)
  done

lemma Abs_bit_eq_of_bool [code_abbrev]:
  \<open>Abs_bit = of_bool\<close>
  by (simp add: fun_eq_iff zero_bit_def one_bit_def)

lemma Rep_bit_eq_odd:
  \<open>Rep_bit = odd\<close>
proof -
  have \<open>\<not> Rep_bit 0\<close>
    by (simp only: zero_bit_def) (subst Abs_bit_inverse, auto)
  then show ?thesis
    by (auto simp flip: Rep_bit_inject simp add: fun_eq_iff)
qed

lemma Rep_bit_iff_odd [code_abbrev]:
  \<open>Rep_bit b \<longleftrightarrow> odd b\<close>
  by (simp add: Rep_bit_eq_odd)

lemma Not_Rep_bit_iff_even [code_abbrev]:
  \<open>\<not> Rep_bit b \<longleftrightarrow> even b\<close>
  by (simp add: Rep_bit_eq_odd)

lemma Not_Not_Rep_bit [code_unfold]:
  \<open>\<not> \<not> Rep_bit b \<longleftrightarrow> Rep_bit b\<close>
  by simp

code_datatype \<open>0::bit\<close> \<open>1::bit\<close>

lemma Abs_bit_code [code]:
  \<open>Abs_bit False = 0\<close>
  \<open>Abs_bit True = 1\<close>
  by (simp_all add: Abs_bit_eq_of_bool)

lemma Rep_bit_code [code]:
  \<open>Rep_bit 0 \<longleftrightarrow> False\<close>
  \<open>Rep_bit 1 \<longleftrightarrow> True\<close>
  by (simp_all add: Rep_bit_eq_odd)

context zero_neq_one
begin

abbreviation of_bit :: \<open>bit \<Rightarrow> 'a\<close>
  where \<open>of_bit b \<equiv> of_bool (odd b)\<close>

end

context
begin

qualified lemma bit_eq_iff:
  \<open>a = b \<longleftrightarrow> (even a \<longleftrightarrow> even b)\<close> for a b :: bit
  by (cases a; cases b) simp_all

end

lemma modulo_bit_unfold [simp, code]:
  \<open>a mod b = of_bool (odd a \<and> even b)\<close> for a b :: bit
  by (simp add: modulo_bit_def Abs_bit_eq_of_bool Rep_bit_eq_odd)

lemma power_bit_unfold [simp, code]:
  \<open>a ^ n = of_bool (odd a \<or> n = 0)\<close> for a :: bit
  by (cases a) simp_all

instantiation bit :: field
begin

definition uminus_bit :: \<open>bit \<Rightarrow> bit\<close>
  where [simp]: \<open>uminus_bit = id\<close>

definition inverse_bit :: \<open>bit \<Rightarrow> bit\<close>
  where [simp]: \<open>inverse_bit = id\<close>

instance
  apply standard
  apply simp_all
  apply (simp only: Z2.bit_eq_iff even_add)
  apply simp
  done

end

instantiation bit :: semiring_bits
begin

definition bit_bit :: \<open>bit \<Rightarrow> nat \<Rightarrow> bool\<close>
  where [simp]: \<open>bit_bit b n \<longleftrightarrow> odd b \<and> n = 0\<close>

instance
  apply standard
              apply auto
  apply (metis bit.exhaust of_bool_eq(2))
  done

end

instantiation bit :: ring_bit_operations
begin

context
  includes bit_operations_syntax
begin

definition not_bit :: \<open>bit \<Rightarrow> bit\<close>
  where [simp]: \<open>NOT b = of_bool (even b)\<close> for b :: bit

definition and_bit :: \<open>bit \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>b AND c = of_bool (odd b \<and> odd c)\<close> for b c :: bit

definition or_bit :: \<open>bit \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>b OR c = of_bool (odd b \<or> odd c)\<close> for b c :: bit

definition xor_bit :: \<open>bit \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>b XOR c = of_bool (odd b \<noteq> odd c)\<close> for b c :: bit

definition mask_bit :: \<open>nat \<Rightarrow> bit\<close>
  where [simp]: \<open>mask n = (of_bool (n > 0) :: bit)\<close>

definition set_bit_bit :: \<open>nat \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>set_bit n b = of_bool (n = 0 \<or> odd b)\<close> for b :: bit

definition unset_bit_bit :: \<open>nat \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>unset_bit n b = of_bool (n > 0 \<and> odd b)\<close> for b :: bit

definition flip_bit_bit :: \<open>nat \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>flip_bit n b = of_bool ((n = 0) \<noteq> odd b)\<close> for b :: bit

definition push_bit_bit :: \<open>nat \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>push_bit n b = of_bool (odd b \<and> n = 0)\<close> for b :: bit

definition drop_bit_bit :: \<open>nat \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>drop_bit n b = of_bool (odd b \<and> n = 0)\<close> for b :: bit

definition take_bit_bit :: \<open>nat \<Rightarrow> bit \<Rightarrow> bit\<close>
  where [simp]: \<open>take_bit n b = of_bool (odd b \<and> n > 0)\<close> for b :: bit

end

instance
  apply standard
             apply auto
  apply (simp only: Z2.bit_eq_iff even_add even_zero)
  done

end

lemma add_bit_eq_xor [simp, code]:
  \<open>(+) = (Bit_Operations.xor :: bit \<Rightarrow> _)\<close>
  by (auto simp add: fun_eq_iff)

lemma mult_bit_eq_and [simp, code]:
  \<open>(*) = (Bit_Operations.and :: bit \<Rightarrow> _)\<close>
  by (simp add: fun_eq_iff)

lemma bit_numeral_even [simp]: "numeral (Num.Bit0 w) = (0 :: bit)"
  by (simp only: Z2.bit_eq_iff even_numeral) simp

lemma bit_numeral_odd [simp]: "numeral (Num.Bit1 w) = (1 :: bit)"
  by (simp only: Z2.bit_eq_iff odd_numeral)  simp

end


(*<*)
header {* Range Semirings *}

theory Range_Semiring
  imports Domain_Semiring
begin

section {* Range Semirings  *}

class range_semiring = semiring_one_zero + plus_ord + r_op +
  assumes r1: "x+(x\<cdot>r(x)) = x\<cdot>r(x)"
  and r2: "r(x\<cdot>y) = r(r(x)\<cdot>y)"
  and r3: "r(x)+1 = 1"
  and r4: "r(0) = 0"
  and r5: "r(x+y) = r(x)+r(y)"

sublocale range_semiring \<subseteq> dual!: domain_semiring
"op +" "op \<odot>" "(1\<Colon>'a)" "(0\<Colon>'a)" "r" "op \<le>" "op <"
proof
  fix x y z :: 'a
  show "x \<odot> y \<odot> z = x \<odot> (y \<odot> z)"
    by (metis mult_assoc opp_mult_def)
  show  "(x + y) \<odot> z = x \<odot> z + y \<odot> z"
    by (metis distrib_left opp_mult_def)
  show  "(1\<Colon>'a) \<odot> x = x"
    by (metis mult_oner opp_mult_def)
  show "x \<odot> (1\<Colon>'a) = x"
    by (metis mult_onel opp_mult_def)
  show  "(0\<Colon>'a) + x = x"
    by (metis add_zerol)
  show "(0\<Colon>'a) \<odot> x = (0\<Colon>'a)"
    by (metis annir opp_mult_def)
  show  "x \<odot> (y + z) = x \<odot> y + x \<odot> z"
    by (metis distrib_right opp_mult_def)
  show "x \<odot> (0\<Colon>'a) = (0\<Colon>'a)"
    by (metis annil opp_mult_def)
  show  "x + r x \<odot> x = r x \<odot> x"
    by (metis opp_mult_def r1)
  show "r (x \<odot> y) = r (x \<odot> r y)"
    by (metis opp_mult_def r2)
  show  "r x + (1\<Colon>'a) = (1\<Colon>'a)"
    by (metis r3)
  show "r (0\<Colon>'a) = (0\<Colon>'a)"
    by (metis r4)
  show "r (x + y) = r x + r y"
    by (metis r5)
qed

context range_semiring
begin
(*
thm dual.mult_isor

subclass dioid_one_zero
proof
  fix x y z :: 'a
  show "x+x = x"
    by (metis add_comm r1 r3 distrib_right mult_onel
qed
*)
lemma r1_eq: "x = x\<cdot>r(x)"
  by (metis dual.d1_eq opp_mult_def)

lemma range_invol: "r(r(x)) = r(x)"
  by (metis dual.domain_invol)

lemma range_fixed_point: "(\<exists>y.(x=r(y))) \<longleftrightarrow> x=r(x)"
  by (metis dual.domain_fixed_point)

lemma range_1: "r(x\<cdot>y) \<le> r(y)"
  by (metis dual.domain_1 opp_mult_def)

lemma range_subid: "x \<le> 1 \<longrightarrow> x \<le> r(x)"
 by (metis dual.domain_subid)

lemma range_very_strict: "r(x) = 0 \<longleftrightarrow> x = 0"
  by (metis dual.domain_very_strict)

lemma range_one: "r(1) = 1"
  by (metis dual.domain_one)

lemma ran_subid: "r(x) \<le> 1"
 by (metis dual.dom_subid)

lemma range_iso: "x \<le> y \<longrightarrow> r(x) \<le> r(y)"
  by (metis dual.domain_iso)

lemma range_subdist: "r(x) \<le> r(x+y)"
  by (metis dual.domain_subdist)

lemma range_export: "r(x\<cdot>r(y)) = r(x)\<cdot>r(y)"
 by (metis dual.domain_export opp_mult_def)

lemma ran_el_idemp: "r(x)\<cdot>r(x) = r(x)"
  by (metis dual.dom_el_idemp opp_mult_def)

lemma ran_el_comm: "r(x)\<cdot>r(y) = r(y)\<cdot>r(x)"
  by (metis dual.dom_el_comm opp_mult_def)

lemma ran_llp: "x \<le> x\<cdot>r(y) \<longleftrightarrow> r(x) \<le> r(y)"
  by (metis dual.dom_llp opp_mult_def)

lemma ran_weakly_local: "x\<cdot>y = 0 \<longleftrightarrow> r(x)\<cdot>y = 0"
 by (metis dual.dom_weakly_local opp_mult_def)

lemma ran_add_closed: "r(r(x)+r(y)) = r(x)+r(y)"
  by (metis dual.dom_add_closed)

lemma ran_mult_closed: "r(r(x)\<cdot>r(y)) = r(x)\<cdot>r(y)"
  by (metis dual.dom_mult_closed opp_mult_def)

lemma ran_lb: "r(x)\<cdot>r(y) \<le> r(y)"
  by (metis dual.dom_lb opp_mult_def)

lemma ran_glb: "r(x) \<le> r(y)\<cdot>r(z) \<longleftrightarrow> (r(x) \<le> r(y) \<and> r(x) \<le> r(z))"
  by (metis dual.dom_glb opp_mult_def)

lemma range_absorption_1: "(r(x)+r(y))\<cdot>r(x)=r(x)"
  by (metis dual.domain_absorption_1 opp_mult_def)

lemma range_absorption_2: "r(x)+(r(y)\<cdot>r(x))=r(x)"
  by (metis dual.domain_absorption_2 opp_mult_def)

lemma range_distributivity: "r(x)+(r(z)\<cdot>r(y))=(r(x)+r(z))\<cdot>(r(x)+r(y))"
  by (metis dual.domain_distributivity opp_mult_def)

lemma range_order: "r(x) \<le> r(y) \<longleftrightarrow> r(x)=r(y)\<cdot>r(x)"
  by (metis dual.domain_order opp_mult_def)

end

section {* Antirange Semirings *}

class antirange_semiring = semiring_one_zero + plus_ord + ar_op +
  assumes ar1: "x\<cdot>ar(x) = 0"
  and ar2: "ar(x\<cdot>y)+ar(ar(ar(x))\<cdot>y) = ar(ar(ar(x))\<cdot>y)"
  and ar3: "ar(ar(x))+ar(x) = 1"

sublocale antirange_semiring \<subseteq> dual!: antidomain_semiring
"op +" "op \<odot>" "(1\<Colon>'a)" "(0\<Colon>'a)" "ar" "op \<le>" "op <"
proof
  fix x y z :: 'a
  show "x \<odot> y \<odot> z = x \<odot> (y \<odot> z)"
    by (metis mult_assoc opp_mult_def)
  show  "(x + y) \<odot> z = x \<odot> z + y \<odot> z"
    by (metis distrib_left opp_mult_def)
  show  "(1\<Colon>'a) \<odot> x = x"
    by (metis mult_oner opp_mult_def)
  show "x \<odot> (1\<Colon>'a) = x"
    by (metis mult_onel opp_mult_def)
  show  "(0\<Colon>'a) + x = x"
    by (metis add_zerol)
  show "(0\<Colon>'a) \<odot> x = (0\<Colon>'a)"
    by (metis annir opp_mult_def)
  show  "x \<odot> (y + z) = x \<odot> y + x \<odot> z"
    by (metis distrib_right opp_mult_def)
  show "x \<odot> (0\<Colon>'a) = (0\<Colon>'a)"
    by (metis annil opp_mult_def)
  show "ar x \<odot> x = (0\<Colon>'a)"
    by (metis ar1 opp_mult_def)
  show "ar (x \<odot> y) + ar (x \<odot> ar (ar y)) = ar (x \<odot> ar (ar y))"
    by (metis ar2 opp_mult_def)
  show "ar (ar x) + ar x = (1\<Colon>'a)"
    by (metis ar3)
qed

context antirange_semiring
begin

text {* Definition of range. *}

definition
  antirange_semiring_range :: "'a \<Rightarrow> 'a" ("r")
  where "r(x) = ar(ar(x))"
(*
subclass dioid
proof
  fix x y z :: 'a
  show "x+x = x"
    by (metis dual.add_idem)
  show "z\<cdot>x \<le> z\<cdot>(x+y)"
    by (metis distl dual.order_prop)
 qed
*)
lemma ar_subid: "ar(x) \<le> 1"
  by (metis dual.a_subid)

lemma ar_gla: "x\<cdot>ar(y) = 0 \<longleftrightarrow> ar(y) \<le> ar(x)"
 by (metis dual.a_gla opp_mult_def)

lemma ar2_eq: "ar(x\<cdot>y) = ar(r(x)\<cdot>y)"
  by (metis antirange_semiring_range_def dual.a2_eq dual.antidomain_semiring_domain_def opp_mult_def)

lemma ar_closure:  "r(ar(x)) = ar(x)"
  by (metis antirange_semiring_range_def dual.a_closure dual.antidomain_semiring_domain_def)

lemma ar_subdist: "ar(x+y) \<le> ar(x)"
  by (metis dual.a_subdist)

lemma ar_idem: "ar(x)\<cdot>ar(x) = ar(x)"
  by (metis dual.a_idem opp_mult_def)

lemma ar_1: "ar(x) = 1 \<longrightarrow> x = 0"
 by (metis dual.a_1)

lemma ar_3: "r(x+y)\<cdot>(ar(y)\<cdot>ar(x)) = 0"
  by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.a_3 opp_mult_def)

lemma ar_add: "ar(y)\<cdot>ar(x) = ar(x+y)"
  by (metis dual.a_add opp_mult_def)

lemma ar_export: "ar(y\<cdot>ar(x)) = r(x)+ar(y)"
 by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.a_export opp_mult_def)

end

sublocale antirange_semiring < range: range_semiring "op +" "op \<cdot>" "(1\<Colon>'a)" "(0\<Colon>'a)" "r" "op \<le>" "op <"
proof
  fix x y :: 'a
  have  "x = x\<cdot>r(x)"
    by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.d1_eq opp_mult_def)
   thus "x+x\<cdot>r(x) = x\<cdot>r(x)"
     by (metis dual.order_refl less_eq_def)
   show  "r(x\<cdot>y) = r(r(x)\<cdot>y)"
     by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.d2 opp_mult_def)
  show "r(x)+1 = 1"
    by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.d3)
  show  "r(0) = 0"
    by (metis antirange_semiring_range_def dual.a_one dual.a_zero)
   show  "r(x+y) = r(x)+r(y)"
     by (metis antirange_semiring_range_def ar_add ar_export)
qed

context antirange_semiring
begin

lemma ar_zero: "ar(0) = 1"
  by (metis dual.a_zero)

lemma ar_one: "ar(1) = 0"
   by (metis dual.a_one)

lemma ar_comp_1: "ar(x)\<cdot>r(x) = 0"
 by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.a_comp_1 opp_mult_def)

lemma ar_comp_2: "r(x)\<cdot>ar(x) = 0"
by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.a_comp_2 opp_mult_def)

lemma ar_2_var: "r(x)\<cdot>ar(y) = 0 \<longleftrightarrow> ar(y) \<le> ar(x)"
by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.a_2_var opp_mult_def)

lemma ar_antitone: "x \<le> y \<longrightarrow> ar(y) \<le> ar(x)"
 by (metis dual.a_antitone)

lemma ar_de_morgan: "ar(ar(y)\<cdot>ar(x)) = r(x+y)"
by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.a_de_morgan opp_mult_def)

lemma ar_de_morgan_var_1: "ar(ar(y)\<cdot>ar(x)) = r(x)+r(y)"
by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.a_de_morgan_var_1 opp_mult_def)

lemma ar_de_morgan_var_2: "ar(ar(x)+ar(y)) = r(y)\<cdot>r(x)"
by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.a_de_morgan_var_2 opp_mult_def)

lemma ar_de_morgan_var_3: "ar(r(x)+r(y)) =ar(x)\<cdot>ar(y)"
  by (metis antirange_semiring_range_def ar_add dual.a_5 dual.add_comm dual.antidomain_semiring_domain_def)

lemma ar_de_morgan_var_4: "ar(r(x)\<cdot>r(y))=ar(x)+ar(y)"
  by (metis antirange_semiring_range_def ar_add dual.a_d_add_closure dual.add_comm dual.antidomain_semiring_domain_def)

lemma ar_comm: "ar(x)\<cdot>ar(y) = ar(y)\<cdot>ar(x)"
  by (metis dual.a_comm opp_mult_def)

lemma ar_4: "ar(x) \<le> ar(y\<cdot>x)"
  by (metis dual.a_4 opp_mult_def)

lemma ar_5: "ar(r(x)) = ar(x)"
by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.a_5)

lemma ar_6: "ar(x\<cdot>r(y)) = ar(y)+ar(x)"
by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.a_6 opp_mult_def)

lemma ar_7: "ar(r(y)+r(z))\<cdot>r(x) = ar(z)\<cdot>ar(y)\<cdot>r(x)"
  by (metis antirange_semiring_range_def ar_add dual.a_5 dual.antidomain_semiring_domain_def)

lemma r_ar_galois1: "ar(x)\<cdot>r(y) \<le> r(z) \<longleftrightarrow> r(y) \<le> r(z)+r(x)"
by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.d_a_galois1 opp_mult_def)

lemma r_ar_galois2: "r(y)\<cdot>r(x) \<le> r(z) \<longleftrightarrow> r(x) \<le> r(z)+ar(y)"
by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.d_a_galois2 opp_mult_def)

lemma r_cancellation_1: "r(x) \<le> r(y)+(r(x)\<cdot>ar(y))"
by (metis antirange_semiring_range_def ar_add dual.add_comm dual.antidomain_semiring_domain_def dual.d_cancellation_1 opp_mult_def)

lemma r_cancellation_2: "(r(z)+r(y))\<cdot>ar(y) \<le> r(z)"
by (metis antirange_semiring_range_def ar_add dual.add_comm dual.antidomain_semiring_domain_def dual.d5 dual.d_cancellation_2 opp_mult_def)

lemma ar_r_add_closure: "r(ar(x)+ar(y))=ar(x)+ar(y)"
by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.a_d_add_closure)

lemma ar_r_mult_closure: "r(ar(x)\<cdot>ar(y))=ar(x)\<cdot>ar(y)"
by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.a_d_mult_closure opp_mult_def)

lemma r_ar_zero: "r(x)\<cdot>ar(y) = 0 \<longleftrightarrow> r(x) \<le> r(y)"
  by (metis antirange_semiring_range_def ar_add dual.add_comm dual.antidomain_semiring_domain_def dual.d_a_zero opp_mult_def)

lemma r_r_zero: "r(x)\<cdot>r(y) = 0 \<longleftrightarrow> r(x) \<le> ar(y)"
  by (metis antirange_semiring_range_def ar_comm dual.antidomain_semiring_domain_def dual.d_d_zero opp_mult_def)

lemma r_6: "r(x)+r(y) = r(x)+ar(x)\<cdot>r(y)"
by (metis antirange_semiring_range_def ar_add dual.add_comm dual.antidomain_semiring_domain_def dual.d_6 opp_mult_def)

lemma r_7: "ar(x)+ar(y) = ar(x)+r(x)\<cdot>ar(y)"
by (metis antirange_semiring_range_def ar_add dual.add_comm dual.antidomain_semiring_domain_def dual.d_7 opp_mult_def)

lemma rkat_1_equiv: "r(x)\<cdot>y \<le> y\<cdot>r(z) \<longleftrightarrow> y\<cdot>ar(z) \<le> ar(x)\<cdot>y"
  by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.kat_1_equiv_opp opp_mult_def)

lemma rkat_2_equiv:  "y\<cdot>ar(z) \<le> ar(x)\<cdot>y \<longleftrightarrow> r(x)\<cdot>y\<cdot>ar(z) = 0"
  by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.kat_2_equiv_opp mult_assoc opp_mult_def)

lemma rkat_3_equiv: "r(x)\<cdot>y\<cdot>ar(z) = 0 \<longleftrightarrow> r(x)\<cdot>y = r(x)\<cdot>y\<cdot>r(z)"
  by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.kat_3_equiv_opp mult_assoc opp_mult_def)

lemma rkat_4_equiv: "r(x)\<cdot>y = r(x)\<cdot>y\<cdot>r(z) \<longleftrightarrow> r(x)\<cdot>y \<le> y\<cdot>r(z)"
  by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.kat_4_equiv_opp mult_assoc opp_mult_def)

lemma rkat_1_equiv_opp: "y\<cdot>r(x) \<le> r(z)\<cdot>y \<longleftrightarrow> ar(z)\<cdot>y \<le> y\<cdot>ar(x)"
  by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.kat_1_equiv opp_mult_def)

lemma rkat_2_equiv_opp:  "ar(z)\<cdot>y \<le> y\<cdot>ar(x) \<longleftrightarrow> ar(z)\<cdot>y\<cdot>r(x) = 0"
  by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.kat_2_equiv mult_assoc opp_mult_def)

lemma rkat_3_equiv_opp: "ar(z)\<cdot>y\<cdot>r(x) = 0 \<longleftrightarrow> y\<cdot>r(x) = r(z)\<cdot>y\<cdot>r(x)"
  by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.kat_3_equiv mult_assoc opp_mult_def)

lemma rkat_4_equiv_opp: "y\<cdot>r(x) = r(z)\<cdot>y\<cdot>r(x) \<longleftrightarrow> y\<cdot>r(x) \<le> r(z)\<cdot>y"
  by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.kat_4_equiv mult_assoc opp_mult_def)

end

class antirange_kleene_algebra = antirange_semiring + kleene_algebra

sublocale antirange_kleene_algebra \<subseteq> dual!: antidomain_kleene_algebra
"op +" "op \<odot>" "(1\<Colon>'a)" "(0\<Colon>'a)" "ar" "op \<le>" "op <" "star"
proof
  fix x y z :: 'a
  show "(1\<Colon>'a) + x \<odot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
    by (metis opp_mult_def order_refl star_unfoldr_eq)
  show  "z + x \<odot> y \<le> y \<longrightarrow> x\<^sup>\<star> \<odot> z \<le> y"
    by (metis opp_mult_def star_inductr)
  show  "z + y \<odot> x \<le> y \<longrightarrow> z \<odot> x\<^sup>\<star> \<le> y"
    by (metis opp_mult_def star_inductl)
qed

context antirange_kleene_algebra
begin

lemma brange_star: "r(x\<^sup>\<star>) = 1"
  by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.fdom_star)

end

text {* Hence all range theorems have been derived by duality in a generic way *}

section{* Backward Diamond *}

class bdiamond_semiring = antirange_semiring + bdiamond_op +
  assumes bdiamond_def:  "\<langle>x\<bar>y  =  r(y\<cdot>x)"

sublocale bdiamond_semiring \<subseteq> dual!: fdiamond_semiring
"op +" "op \<odot>"  "(1\<Colon>'a)" "(0\<Colon>'a)" "ar" "op \<le>" "op <" "bdiamond"
proof
  fix x y :: 'a
  show "\<langle> x \<bar> y = antidomain_semiring.antidomain_semiring_domain ar (x \<odot> y)"
    by (metis antirange_semiring_range_def bdiamond_def dual.antidomain_semiring_domain_def opp_mult_def)
qed

context bdiamond_semiring
begin

lemma bdia_simp: "\<langle>x\<bar>p = \<langle>x\<bar>r(p)"
  by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.fdia_simp)

lemma bdia_simp_2:  "\<langle>x\<bar>p =r(\<langle>x\<bar>p)"
  by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.fdia_simp_2)

lemma bdia_ran: "r(x) =\<langle>x\<bar>1"
  by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.fdia_dom)

lemma bdia_add1: "\<langle>x\<bar>(y+z) = (\<langle>x\<bar>y)+(\<langle>x\<bar>z)"
  by (metis dual.fdia_add1)

lemma bdia_add2: "\<langle>x+y\<bar>z = (\<langle>x\<bar>z)+(\<langle>y\<bar>z)"
  by (metis dual.fdia_add2)

lemma bdia_mult: "\<langle>x\<cdot>y\<bar>z = \<langle>y\<bar>(\<langle>x\<bar>z)"
  by (metis dual.fdia_mult opp_mult_def)

lemma rdia_one: "\<langle>1\<bar>x = r(x)"
  by (metis bdia_ran dual.fdia_dom dual.fdia_one)

lemma rdia_zero: "\<langle>x\<bar>0 = 0"
  by (metis dual.fdia_zero)

lemma rdemodalisation1: "(\<langle>x\<bar>y)\<cdot>r(z) = 0 \<longleftrightarrow> r(y)\<cdot>(x\<cdot>r(z)) = 0"
  by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.fdemodalisation1 opp_mult_def)

lemma rdemodalisation2: "\<langle>x\<bar>y \<le> r(z) \<longleftrightarrow> r(y)\<cdot>(x\<cdot>ar(z)) = 0"
  by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.fdemodalisation2 opp_mult_def)

lemma rdemodalisation3: "\<langle>x\<bar>y \<le> r(z) \<longleftrightarrow> r(y)\<cdot>x \<le> x\<cdot>r(z)"
  by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.fdemodalisation3 opp_mult_def)

lemma rdia_iso: "r(x) \<le> r(y) \<longrightarrow> \<langle>z\<bar>x \<le> \<langle>z\<bar>y"
  by (metis dual.fdia_iso dual.fdia_one rdia_one)

lemma bdia_zero_var: "\<langle>0\<bar>x = 0"
 by (metis dual.fdia_zero_var)

lemma bdia_export_1:  "(\<langle>x\<bar>p)\<cdot>r(y) = \<langle>x\<cdot>r(y)\<bar>p"
  by (metis bdia_ran dual.fdia_dom dual.fdia_export_1 opp_mult_def)

lemma bdia_export_2: "(\<langle>x\<bar>p)\<cdot>ar(y) = \<langle>x\<cdot>ar(y)\<bar>p"
 by (metis dual.fdia_export_2 opp_mult_def)

lemma bdia_split: "\<langle>x\<bar>y = r(z)\<cdot>(\<langle>x\<bar>y)+ar(z)\<cdot>(\<langle>x\<bar>y)"
  by (smt antirange_semiring_range_def ar_add bdiamond_def dual.add_comm dual.antidomain_semiring_domain_def dual.fdia_split opp_mult_def)
end

section {* Backward Box *}

class bmodal_semiring = bdiamond_semiring + bbox_op +
  assumes bbox_def:  "([x\<bar>y) = ar(ar(y)\<cdot>x)"

sublocale bmodal_semiring \<subseteq> dual!: fmodal_semiring
bbox  "op +" "op \<odot>" "(1\<Colon>'a)" "(0\<Colon>'a)" ar "op \<le>" "op <" bdiamond
proof
  fix x y :: 'a
  show  "[  x \<bar> y = ar (x \<odot> ar y)"
    by (metis bbox_def opp_mult_def)
qed

context bmodal_semiring
begin

lemma bbox_bdia: "[x\<bar>y = ar(\<langle>x\<bar>ar(y))"
 by (metis dual.fbox_fdia)

lemma bdia_bbox: "\<langle>x\<bar>y = ar([x\<bar>ar(y))"
 by (metis dual.fdia_fbox)

lemma bbox_ran: "ar(x) =[x\<bar>0"
 by (metis dual.fbox_dom)

lemma bbox_add1: "[x\<bar>(r(y)\<cdot>r(z)) = ([x\<bar>y)\<cdot>([x\<bar>z)"
  by (metis antirange_semiring_range_def ar_6 ar_add dual.a_5 dual.antidomain_semiring_domain_def dual.fbox_fdia dual.fdia_add1)

lemma bbox_add2: "[x+y\<bar>z = ([y\<bar>z)\<cdot>([x\<bar>z)"
 by (metis dual.fbox_add2 opp_mult_def)

lemma bbox_mult: "[x\<cdot>y\<bar>z = [y\<bar>([x\<bar>z)"
 by (metis dual.fbox_mult opp_mult_def)

lemma bbox_one: "[1\<bar>x = r(x)"
  by (metis dual.fbox_one dual.fdia_one rdia_one)

lemma bbox_one_1: "[x\<bar>1 = 1"
 by (metis dual.fbox_one_1)

lemma bbox_demodalisation3: "r(y) \<le> [x\<bar>r(z) \<longleftrightarrow> x\<cdot>r(y) \<le> r(z)\<cdot>x"
  by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.fbox_demodalisation3 opp_mult_def)

lemma bbox_iso: "r(x) \<le> r(y) \<longrightarrow> [z\<bar>x \<le> [z\<bar>y"
  by (metis dual.fbox_iso dual.fdia_one rdia_one)

lemma bbox_zero_var: "[0\<bar>x = 1"
  by (metis dual.a_zero dual.fbox_fdia dual.fdia_zero_var)

end

class bmodal_kleene_algebra = bmodal_semiring + kleene_algebra

sublocale bmodal_kleene_algebra \<subseteq> dual!: fmodal_kleene_algebra
 "bbox" "op +" "op \<odot>" "(1\<Colon>'a)" "(0\<Colon>'a)" "ar"  "op \<le>" "op <""bdiamond" "star"
proof
  fix x y z :: 'a
  show "(1\<Colon>'a) + x \<odot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
    by (metis opp_mult_def order_refl star_slide_var star_unfoldl_eq)
  show "z + x \<odot> y \<le> y \<longrightarrow> x\<^sup>\<star> \<odot> z \<le> y"
    by (metis opp_mult_def star_inductr)
  show "z + y \<odot> x \<le> y \<longrightarrow> z \<odot> x\<^sup>\<star> \<le> y"
    by (metis opp_mult_def star_inductl)
qed

context bmodal_kleene_algebra
begin
lemma brange_star: "r(x\<^sup>\<star>) = 1"
  by (metis antirange_semiring_range_def dual.a_star dual.a_zero)

lemma bdia_star_unfold: "(\<langle>1\<bar>z)+(\<langle>x\<bar>(\<langle>x\<^sup>\<star>\<bar>z)) = \<langle>x\<^sup>\<star>\<bar>z"
 by (metis dual.fdia_star_unfold)

lemma bdia_star_unfold_var: "r(z)+(\<langle>x\<bar>(\<langle>x\<^sup>\<star>\<bar>z)) = \<langle>x\<^sup>\<star>\<bar>z"
  by (metis antirange_semiring_range_def ar2_eq bbox_def dual.antidomain_semiring_domain_def dual.fdia_fbox dual.fdia_star_unfoldr_var mult_assoc star_slide_var)

lemma bdia_star_unfold_var_2: "r(z)+\<langle>x\<bar>(\<langle>x\<^sup>\<star>\<bar>r(z)) = \<langle>x\<^sup>\<star>\<bar>r(z)"
  by (metis antirange_semiring_range_def ar_closure bdia_star_unfold_var)

lemma bdia_star_induct_var: "\<langle>x\<bar>r(y) \<le> r(y) \<longrightarrow> \<langle>x\<^sup>\<star>\<bar>r(y) \<le> r(y)"
  by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.fdia_star_induct_var)

lemma bdia_star_induct: "r(z)+(\<langle>x\<bar>r(y)) \<le> r(y) \<longrightarrow> \<langle>x\<^sup>\<star>\<bar>r(z) \<le> r(y)"
  by (metis antirange_semiring_range_def dual.antidomain_semiring_domain_def dual.fdia_star_induct)

end

text {* Hence all range theorems have been derived by duality in a generic way *}

end
(*>*)


(* Title: Propositional Hoare Logic
   Author: Georg Struth
*)

section \<open>Propositional Hoare Logic\<close>

theory PHL
  imports KAT

begin

subsection \<open>Deriving the rules of PHL in KAT\<close>

context kat
begin

definition Ho :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "Ho p x q = (\<tau> p \<cdot> x \<le> x \<cdot> \<tau> q)"

definition while_inv :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ inv _ do _ od" [64,64,64] 63) where
  "while p inv i do x od = while p do x od"

lemma H_def_var: "Ho p x q = (\<tau> p \<cdot> x \<cdot> \<alpha> q = 0)"
  sorry

lemma H_abort: "Ho p 0 q"
  sorry

lemma H_skip: "Ho p 1 p"
  sorry

lemma H_cons:
  assumes "\<tau> p \<le> \<tau> p'"
  and "Ho p' x q'"
  and "\<tau> q' \<le> \<tau> q"
shows "Ho p x q"
  sorry

lemma H_seq:
  assumes "Ho r y q"
  and "Ho p x r"
  shows "Ho p (x \<cdot> y) q"
  sorry

lemma H_cond:
  assumes "Ho (\<tau> p \<cdot> \<tau> r) x q"
  and "Ho (\<tau> p \<cdot> \<alpha> r) y q"
  shows "Ho p (if r then x else y fi) q"
  sorry

lemma H_cond_iff: "Ho p (if r then x else y fi) q = (Ho (\<tau> p \<cdot> \<tau> r) x q \<and> Ho (\<tau> p \<cdot> \<alpha> r) y q)"
  sorry

lemma H_while:
  assumes "Ho (\<tau> p \<cdot> \<tau> r) x p"
  shows "Ho p (while r do x od) (\<tau> p \<cdot> \<alpha> r)"
  sorry

lemma H_inv:
  assumes "\<tau> p \<le> \<tau> i"
  and "Ho i x i"
  and "\<tau> i \<le> \<tau> q"
  shows "Ho p x q"
  sorry

lemma H_inv_seq:
  assumes "Ho i x i"
  and "Ho j x j"
  shows "Ho (\<tau> i \<cdot> \<tau> j) x (\<tau> i \<cdot> \<tau> j)"
  sorry

lemma H_inv_add:
  assumes "Ho i x i"
  and "Ho j x j"
shows "Ho (\<tau> i + \<tau> j) x (\<tau> i + \<tau> j)"
  sorry

lemma H_while_inv:
  assumes "\<tau> p \<le> \<tau> i"
  and "\<tau> i \<cdot> \<alpha> r \<le> \<tau> q"
  and "Ho (\<tau> i \<cdot> \<tau> r) x i"
shows "Ho p (while r inv i do x od) q"
  sorry

end

subsection \<open>Hoare Triples in the Relational and State Transformer Model\<close>

text \<open>First we consider relations.\<close>

abbreviation rH :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a pred \<Rightarrow> bool" ("H\<^sub>r") where
  "H\<^sub>r P R Q \<equiv> rel_kat.Ho \<lceil>P\<rceil>\<^sub>r R \<lceil>Q\<rceil>\<^sub>r"

abbreviation rcond :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("rif _ then _ else _ fi" [64,64,64] 63) where
  "rif P then R else S fi \<equiv> rel_kat.cond \<lceil>P\<rceil>\<^sub>r R S"

abbreviation rwhile :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("rwhile _ do _ od" [64,64] 63) where
  "rwhile P do R od \<equiv> rel_kat.while \<lceil>P\<rceil>\<^sub>r R"

abbreviation rwhile_inv :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("rwhile _ inv _ do _ od" [64,64,64] 63) where
  "rwhile P inv I do R od \<equiv> rel_kat.while_inv \<lceil>P\<rceil>\<^sub>r \<lceil>I\<rceil>\<^sub>r R"

lemma rH_unfold: "H\<^sub>r P R Q = (\<forall>x y. P x \<longrightarrow> (x,y) \<in> R \<longrightarrow> Q y)"
  unfolding p2r_def rel_kat.Ho_def rel_kat.test_def rel_atest_def by force

lemma rH_skip: "H\<^sub>r P Id Q = (\<forall>x. P x \<longrightarrow> Q x)"
  by (simp add: rH_unfold)

lemma rH_cons1:
  assumes  "H\<^sub>r P' R Q"
  and "\<forall>x. P x \<longrightarrow> P' x"
  shows "H\<^sub>r P R Q"
  sorry

lemma rH_cons2:
  assumes "H\<^sub>r P R Q'"
  and "\<forall>x. Q' x \<longrightarrow> Q x"
  shows "H\<^sub>r P R Q"
  sorry

lemma rH_cons:
  assumes "H\<^sub>r P' R Q'"
  and "\<forall>x. P x \<longrightarrow> P' x"
  and "\<forall>x. Q' x \<longrightarrow> Q x"
 shows "H\<^sub>r P R Q"
  sorry

lemma rH_cond [simp]: "(H\<^sub>r P (rif T then R else S fi) Q) = (H\<^sub>r (\<lambda>s. P s \<and> T s) R Q \<and> H\<^sub>r (\<lambda> s. P s \<and> \<not> T s) S Q)"
  sorry

lemma rH_while_inv:
  assumes "H\<^sub>r (\<lambda>s. I s \<and> T s) R I"
  and "\<forall>x. P x \<longrightarrow> I x"
  and "\<forall>x. I x \<and> \<not> T x \<longrightarrow> Q x"
  shows "H\<^sub>r P (rwhile T inv I do R od) Q"
  sorry

lemma rH_while:
  assumes "H\<^sub>r (\<lambda>s. P s \<and> T s) R P"
  shows "H\<^sub>r P (rwhile T do R od) (\<lambda>s. P s \<and> \<not> T s)"
  sorry

text \<open>Next we repeat the development with state transformers.\<close>

abbreviation Hs :: "'a pred \<Rightarrow> 'a sta \<Rightarrow> 'a pred \<Rightarrow> bool" ("H\<^sub>s") where
  "H\<^sub>s P f Q \<equiv> sta_kat.Ho \<lceil>P\<rceil>\<^sub>s f \<lceil>Q\<rceil>\<^sub>s"

abbreviation scond :: "'a pred \<Rightarrow> 'a sta \<Rightarrow> 'a sta \<Rightarrow> 'a sta" ("sif _ then _ else _ fi" [64,64,64] 63) where
  "sif P then f else g fi \<equiv> sta_kat.cond \<lceil>P\<rceil>\<^sub>s f g"

abbreviation swhile :: "'a pred \<Rightarrow> 'a sta \<Rightarrow> 'a sta" ("swhile _ do _ od" [64,64] 63) where
  "swhile P do f od \<equiv> sta_kat.while \<lceil>P\<rceil>\<^sub>s f"

abbreviation swhile_inv :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a sta \<Rightarrow> 'a sta" ("swhile _ inv _ do _ od" [64,64,64] 63) where
  "swhile P inv I do f od \<equiv> sta_kat.while_inv \<lceil>P\<rceil>\<^sub>s \<lceil>I\<rceil>\<^sub>s f"

lemma sH_unfold: "H\<^sub>s P f Q = (\<forall>x y. P x \<longrightarrow> y \<in> f x \<longrightarrow> Q y)"
  sorry

lemma sH_skip: "H\<^sub>s P \<eta> Q = (\<forall>x. P x \<longrightarrow> Q x)"
  sorry

lemma sH_cons1:
  assumes "H\<^sub>s P' f Q"
  and "\<forall>x. P x \<longrightarrow> P' x"
  shows "H\<^sub>s P f Q"
  sorry

lemma sH_cons2:
  assumes "H\<^sub>s P f Q'"
  and "\<forall>x. Q' x \<longrightarrow> Q x"
  shows "H\<^sub>s P f Q"
  sorry

lemma sH_cons:
  assumes "H\<^sub>s P' f Q'"
  and "\<forall>x. P x \<longrightarrow> P' x"
  and "\<forall>x. Q' x \<longrightarrow> Q x"
  shows "H\<^sub>s P f Q"
  sorry

lemma sH_cond [simp]: "(H\<^sub>s P (sif T then f else g fi) Q) = (H\<^sub>s (\<lambda>s. P s \<and> T s) f Q \<and> H\<^sub>s (\<lambda> s. P s \<and> \<not>T s) g Q)"
  sorry

lemma sH_while_inv:
  assumes "H\<^sub>s (\<lambda>s. I s \<and> T s) f I"
  and "\<forall>s. P s \<longrightarrow> I s"
  and "\<forall>s. I s \<and> \<not> T s \<longrightarrow> Q s"
  shows "H\<^sub>s P (swhile T inv I do f od) Q"
  sorry

lemma sH_while:
  assumes "H\<^sub>s (\<lambda>s. P s \<and> T s) f P"
  shows "H\<^sub>s P (swhile T do f od) (\<lambda>s. P s \<and> \<not> T s)"
  sorry

text \<open>We have taken care that the verification condition generation for relations and state transformers is the same.\<close>

end


theory prop_84
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype ('a, 'b) Pair2 = Pair "'a" "'b"
  datatype Nat = Z | S "Nat"
  fun zip :: "'a list => 'b list => (('a, 'b) Pair2) list" where
  "zip (Nil2) y = Nil2"
  | "zip (Cons2 z x2) (Nil2) = Nil2"
  | "zip (Cons2 z x2) (Cons2 x3 x4) = Cons2 (Pair z x3) (zip x2 x4)"
  fun take :: "Nat => 'a list => 'a list" where
  "take (Z) y = Nil2"
  | "take (S z) (Nil2) = Nil2"
  | "take (S z) (Cons2 x2 x3) = Cons2 x2 (take z x3)"
  fun len :: "'a list => Nat" where
  "len (Nil2) = Z"
  | "len (Cons2 y xs) = S (len xs)"
  fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) y = y"
  | "drop (S z) (Nil2) = Nil2"
  | "drop (S z) (Cons2 x2 x3) = drop z x3"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  (*hipster zip take len drop append *)
(*hipster take len drop*)
  theorem x0 :
    "(zip xs (append ys zs)) =
       (append (zip (take (len ys) xs) ys) (zip (drop (len ys) xs) zs))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


(* Author: Tobias Nipkow (based on Hauke Brinkop's tree proofs) *)

subsection \<open>Okasaki's Pairing Heap (Modified)\<close>

theory Pairing_Heap_List2_Analysis
imports
  Pairing_Heap.Pairing_Heap_List2
  Amortized_Framework
  Priority_Queue_ops_merge
  Lemmas_log
begin

text
\<open>Amortized analysis of a modified version of the pairing heaps
defined by Okasaki \cite{Okasaki}.\<close>

fun lift_hp :: "'b \<Rightarrow> ('a hp \<Rightarrow> 'b) \<Rightarrow> 'a heap \<Rightarrow> 'b" where
"lift_hp c f None = c" |
"lift_hp c f (Some h) = f h"

fun size_hps :: "'a hp list \<Rightarrow> nat" where
"size_hps(Hp x hsl # hsr) = size_hps hsl + size_hps hsr + 1" |
"size_hps [] = 0"

definition size_hp :: "'a hp \<Rightarrow> nat" where
[simp]: "size_hp h = size_hps(hps h) + 1"

fun \<Phi>_hps :: "'a hp list \<Rightarrow> real" where
"\<Phi>_hps [] = 0" |
"\<Phi>_hps (Hp x hsl # hsr) = \<Phi>_hps hsl + \<Phi>_hps hsr + log 2 (size_hps hsl + size_hps hsr + 1)"

definition \<Phi>_hp :: "'a hp \<Rightarrow> real" where
[simp]: "\<Phi>_hp h = \<Phi>_hps (hps h) + log 2 (size_hps(hps(h))+1)"

abbreviation \<Phi> :: "'a heap \<Rightarrow> real" where
"\<Phi> \<equiv> lift_hp 0 \<Phi>_hp"

abbreviation size_heap :: "'a heap \<Rightarrow> nat" where
"size_heap \<equiv> lift_hp 0 size_hp"

lemma \<Phi>_hps_ge0: "\<Phi>_hps hs \<ge> 0"
by (induction hs rule: size_hps.induct) auto

declare algebra_simps[simp]

lemma size_hps_Cons[simp]: "size_hps(h # hs) = size_hp h + size_hps hs"
by(cases h) simp

lemma link2: "link (Hp x lx) h = (case h of (Hp y ly) \<Rightarrow>
    (if x < y then Hp x (Hp y ly # lx) else Hp y (Hp x lx # ly)))"
by(simp split: hp.split)

lemma size_hps_link: "size_hps(hps (link h1 h2)) = size_hp h1 + size_hp h2 - 1"
by (induction rule: link.induct) simp_all

lemma pass\<^sub>1_size[simp]: "size_hps (pass\<^sub>1 hs) = size_hps hs"
by (induct hs rule: pass\<^sub>1.induct) (simp_all add: size_hps_link)

lemma pass\<^sub>2_None[simp]: "pass\<^sub>2 hs = None \<longleftrightarrow> hs = []"
by(cases hs) auto

lemma \<Delta>\<Phi>_insert:
  "\<Phi> (Pairing_Heap_List2.insert x h) - \<Phi> h \<le> log 2 (size_heap h + 1)"
by(induct h)(auto simp: link2 split: hp.split)

lemma \<Delta>\<Phi>_link: "\<Phi>_hp (link h1 h2) - \<Phi>_hp h1 - \<Phi>_hp h2 \<le> 2 * log 2 (size_hp h1 + size_hp h2)"
by (induction h1 h2 rule: link.induct) (simp  add: add_increasing)

fun sum_ub :: "'a hp list \<Rightarrow> real" where
  "sum_ub [] = 0"
| "sum_ub [Hp _ _] = 0"
| "sum_ub [Hp _ lx, Hp _ ly] = 2*log 2 (2 + size_hps lx + size_hps ly)"
| "sum_ub (Hp _ lx # Hp _ ly # ry) = 2*log 2 (2 + size_hps lx + size_hps ly + size_hps ry)
    - 2*log 2 (size_hps ry) - 2 + sum_ub ry"

lemma \<Delta>\<Phi>_pass1_sum_ub: "\<Phi>_hps (pass\<^sub>1 h) - \<Phi>_hps h  \<le> sum_ub h"
proof (induction h rule: sum_ub.induct)
  case (3 lx x ly y)
  have 0: "\<And>x y::real. 0 \<le> x \<Longrightarrow> x \<le> y \<Longrightarrow> x \<le> 2*y" by linarith
  show ?case by (simp add: add_increasing 0)
next
  case (4 x hsx y hsy z hsize_hp)
  let ?ry = "z # hsize_hp"
  let ?rx = "Hp y hsy # ?ry"
  let ?h = "Hp x hsx # ?rx"
  have "\<Phi>_hps(pass\<^sub>1 ?h) - \<Phi>_hps ?h
    \<le> log 2 (1 + size_hps hsx + size_hps hsy) - log 2 (1 + size_hps hsy + size_hps ?ry) + sum_ub ?ry"
    using "4.IH" by simp
  also have "log 2 (1 + size_hps hsx + size_hps hsy) - log 2 (1 + size_hps hsy + size_hps ?ry)
    \<le> 2*log 2 (size_hps ?h) - 2*log 2 (size_hps ?ry) - 2"
  proof -
    have "log 2 (1 + size_hps hsx + size_hps hsy) + log 2 (size_hps ?ry) - 2*log 2 (size_hps ?h)
      = log 2 ((1 + size_hps hsx + size_hps hsy)/(size_hps ?h) ) + log 2 (size_hps ?ry / size_hps ?h)"
      by (simp add: log_divide)
    also have "\<dots> \<le> -2"
    proof -
      have "2 + \<dots>
        \<le> 2*log 2 ((1 + size_hps hsx + size_hps hsy) / size_hps ?h +  size_hps ?ry / size_hps ?h)"
        using ld_sum_inequality [of "(1 + size_hps hsx + size_hps hsy) / size_hps ?h" "(size_hps ?ry / size_hps ?h)"] by simp
      also have "\<dots> \<le> 0" by (simp add: field_simps log_divide add_pos_nonneg)
      finally show ?thesis by linarith
    qed
    finally have "log 2 (1 + size_hps hsx + size_hps hsy) + log 2 (size_hps ?ry) + 2
      \<le>  2*log 2 (size_hps ?h)" by simp
    moreover have "log 2 (size_hps ?ry) \<le> log 2 (size_hps ?rx)" by simp
    ultimately have "log 2 (1 + size_hps hsx + size_hps hsy) - \<dots>
      \<le>  2*log 2 (size_hps ?h) - 2*log 2 (size_hps ?ry) - 2" by linarith
    thus ?thesis by simp
  qed
  finally show ?case by (simp)
qed simp_all

lemma \<Delta>\<Phi>_pass1: assumes "hs \<noteq> []"
  shows "\<Phi>_hps (pass\<^sub>1 hs) - \<Phi>_hps hs \<le> 2 * log 2 (size_hps hs) - length hs + 2"
proof -
  have "sum_ub hs \<le> 2 * log 2 (size_hps hs) - length hs + 2"
    using assms by (induct hs rule: sum_ub.induct) (simp_all)
  thus ?thesis using \<Delta>\<Phi>_pass1_sum_ub[of hs] by linarith
qed

lemma \<Delta>\<Phi>_pass2: "hs \<noteq> [] \<Longrightarrow> \<Phi> (pass\<^sub>2 hs) - \<Phi>_hps hs \<le> log 2 (size_hps hs)"
proof (induction hs)
  case (Cons h hs)
  thus ?case
  proof -
    obtain x hs2 where [simp]: "h = Hp x hs2" by (metis hp.exhaust)
    show ?thesis
    proof (cases "pass\<^sub>2 hs")
      case [simp]: (Some h2)
      obtain y hs3 where [simp]: "h2 = Hp y hs3" by (metis hp.exhaust)
      from size_hps_pass2[OF Some] Cons show ?thesis
        by(cases "hs=[]")(auto simp: add_mono)
    qed simp
  qed
qed simp

lemma \<Delta>\<Phi>_del_min: assumes "hps h \<noteq> []"
  shows "\<Phi> (del_min (Some h)) - \<Phi> (Some h)
  \<le> 3 * log 2 (size_hps(hps h)) - length(hps h) + 2"
proof -
  let ?\<Delta>\<Phi>\<^sub>1 = "\<Phi>_hps(hps h) - \<Phi>_hp h"
  let ?\<Delta>\<Phi>\<^sub>2 = "\<Phi>(pass\<^sub>2(pass\<^sub>1 (hps h))) - \<Phi>_hps (hps h)"
  let ?\<Delta>\<Phi> = "\<Phi> (del_min (Some h)) - \<Phi> (Some h)"
  have "\<Phi>(pass\<^sub>2(pass\<^sub>1(hps h))) - \<Phi>_hps (pass\<^sub>1(hps h)) \<le> log 2 (size_hps(hps h))"
    using \<Delta>\<Phi>_pass2[of "pass\<^sub>1(hps h)"] using size_hps.elims assms by force
  moreover have "\<Phi>_hps (pass\<^sub>1 (hps h)) - \<Phi>_hps (hps h) \<le>  2*\<dots> - length (hps h) + 2"
    using \<Delta>\<Phi>_pass1[OF assms] by blast
  moreover have "?\<Delta>\<Phi>\<^sub>1 \<le> 0" by (cases h) simp
  moreover have "?\<Delta>\<Phi> = ?\<Delta>\<Phi>\<^sub>1 + ?\<Delta>\<Phi>\<^sub>2" by (cases h) simp
  ultimately show ?thesis by linarith
qed

fun exec :: "'a :: linorder op \<Rightarrow> 'a heap list \<Rightarrow> 'a heap" where
"exec Empty [] = None" |
"exec Del_min [h] = del_min h" |
"exec (Insert x) [h] = Pairing_Heap_List2.insert x h" |
"exec Merge [h1,h2] = merge h1 h2"

fun t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 :: "'a hp list \<Rightarrow> nat" where
  "t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 [] = 1"
| "t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 [_] = 1"
| "t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 (_ # _ # hs) = 1 + t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 hs"

fun t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 :: "'a hp list \<Rightarrow> nat" where
 "t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 [] = 1"
| "t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 (_ # hs) = 1 + t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 hs"

fun cost :: "'a :: linorder op \<Rightarrow> 'a heap list \<Rightarrow> nat" where
"cost Empty _ = 1" |
"cost Del_min [None] = 1" |
"cost Del_min [Some(Hp x hs)] = 1 + t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 (pass\<^sub>1 hs) + t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 hs" |
"cost (Insert a) _ = 1" |
"cost Merge _ = 1"

fun U :: "'a :: linorder op \<Rightarrow> 'a heap list \<Rightarrow> real" where
"U Empty _ = 1" |
"U (Insert a) [h] = log 2 (size_heap h + 1) + 1" |
"U Del_min [h] = 3*log 2 (size_heap h + 1) + 5" |
"U Merge [h1,h2] = 2*log 2 (size_heap h1 + size_heap h2 + 1) + 1"

interpretation pairing: Amortized
where arity = arity and exec = exec and cost = cost and inv = "\<lambda>_. True"
and \<Phi> = \<Phi> and U = U
proof (standard, goal_cases)
  case (2 s) show ?case by (cases s) (auto simp: \<Phi>_hps_ge0)
next
  case (3 ss f) show ?case
  proof (cases f)
    case Empty with 3 show ?thesis by(auto)
  next
    case Insert
    thus ?thesis using Insert \<Delta>\<Phi>_insert 3 by auto
  next
    case [simp]: Del_min
    then obtain ho where [simp]: "ss = [ho]" using 3 by auto
    show ?thesis
    proof (cases ho)
      case [simp]: (Some h)
        show ?thesis
        proof (cases h)
        case [simp]: (Hp x hs)
        have "t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 (pass\<^sub>1 hs) + t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 hs \<le> 2 + length hs"
          by (induct hs rule: pass\<^sub>1.induct) simp_all
        hence  "cost f ss \<le> 1 + \<dots>" by simp
        moreover have  "\<Phi> (del_min ho) - \<Phi> ho \<le> 3*log 2 (size_heap ho + 1) - length hs + 2"
        proof (cases "hs = []")
          case False
          hence "\<Phi> (del_min ho) - \<Phi> ho \<le> 3*log 2 (size_hps hs) - length hs + 2"
            using  \<Delta>\<Phi>_del_min[of h] by simp
          also have "\<dots> \<le> 3*log 2 (size_heap ho + 1) - length hs + 2"
            using False size_hps.elims by force
          finally show ?thesis .
        qed simp
        ultimately show ?thesis by simp
      qed
    qed simp
  next
    case [simp]: Merge
    then obtain ho1 ho2 where [simp]: "ss = [ho1, ho2]"
      using 3 by(auto simp: numeral_eq_Suc)
    show ?thesis
    proof (cases "ho1 = None \<or> ho2 = None")
      case True thus ?thesis by auto
    next
      case False
      then obtain h1 h2 where [simp]: "ho1 = Some h1" "ho2 = Some h2" by auto
      have "\<Phi> (merge ho1 ho2) - \<Phi> ho1 - \<Phi> ho2 \<le> 2 * log 2 (size_heap ho1 + size_heap ho2)"
        using \<Delta>\<Phi>_link[of h1 h2] by simp
      also have "\<dots> \<le> 2 * log 2 (size_hp h1 + size_hp h2 + 1)" by (simp)
      finally show ?thesis by(simp)
    qed
  qed
qed simp

end