theory Lazy_Sum_List
  imports "$AFP/Coinductive/Coinductive" Sum_Type
begin

section {* Lazy Sum Lists *}

notation case_sum ("\<langle>_,_\<rangle>" [0,0] 1000)

primrec is_left :: "('a + 'b) \<Rightarrow> bool" where
  "is_left (Inl x) = True"
| "is_left (Inr x) = False"

primrec is_right :: "('a + 'b) \<Rightarrow> bool" where
  "is_right (Inr x) = True"
| "is_right (Inl x) = False"

primrec unl :: "('a, 'b) sum \<Rightarrow> 'a" where
  "unl (Inl x) = x"
| "unl (Inr x) = undefined"

primrec unr :: "('a, 'b) sum \<Rightarrow> 'b" where
  "unr (Inr x) = x"
| "unr (Inl x) = undefined"

lemma not_is_left [simp]: "\<not> is_left x \<longleftrightarrow> is_right x"
  by (cases x) auto

lemma Not_is_left: "is_right = Not \<circ> is_left"
  by (simp add: o_def)

lemma not_is_right [simp]: "\<not> is_right x \<longleftrightarrow> is_left x"
  by (cases x) auto

lemma Not_is_right: "is_left = Not \<circ> is_right"
  by (simp add: o_def)

definition lefts :: "('a + 'b) llist \<Rightarrow> 'a llist" ("\<ll>") where
  "lefts = lmap unl \<circ> lfilter is_left"

definition rights :: "('a + 'b) llist \<Rightarrow> 'b llist" ("\<rr>") where
  "rights = lmap unr \<circ> lfilter is_right"

lemma [dest!]: "xs \<noteq> LNil \<Longrightarrow> \<exists>y ys. xs = LCons y ys"
  by (metis llist.exhaust)

lemma all_rights [simp]: "lfilter is_right (lmap Inr xs) = lmap Inr xs"
  by (simp add: lfilter_lmap)

lemma all_lefts [simp]: "lfilter is_left (lmap Inl xs) = lmap Inl xs"
  by (simp add: lfilter_lmap)

lemma lmap2_id: "(\<And>x. f (g x) = x) \<Longrightarrow> lmap f (lmap g xs) = xs"
  by (simp add: llist.map_comp)

lemma rights_mapr [simp]: "\<rr> (lmap Inr xs) = xs"
  by (auto simp add: rights_def, rule lmap2_id, simp)

lemma lefts_mapl [simp]: "\<ll> (lmap Inl xs) = xs"
  by (auto simp add: lefts_def, rule lmap2_id, simp)

lemma rights_LConsr [simp]: "\<rr> (LCons (Inr x) xs) = LCons x (\<rr> xs)"
  by (auto simp add: rights_def)

lemma rights_LConsl [simp]: "\<rr> (LCons (Inl x) xs) = \<rr> xs"
  by (auto simp add: rights_def)

lemma lefts_LConsl [simp]: "\<ll> (LCons (Inl x) xs) = LCons x (\<ll> xs)"
  by (auto simp add: lefts_def)

lemma lefts_LConsr [simp]: "\<ll> (LCons (Inr x) xs) = \<ll> xs"
  by (auto simp add: lefts_def)

lemma rights_LNil [simp]: "\<rr> LNil = LNil"
  by (auto simp add: rights_def)

lemma lefts_LNil [simp]: "\<ll> LNil = LNil"
  by (auto simp add: lefts_def)

fun swap :: "('a + 'b) \<Rightarrow> ('b, 'a) sum" where
  "swap (Inl x) = Inr x"
| "swap (Inr x) = Inl x"

definition fair :: "('a + 'b) llist \<Rightarrow> bool" where
  "fair l \<equiv> (\<exists>n. is_right (lnth l n)) \<and> (\<exists>n. is_left (lnth l n))
          \<and> (\<forall>n. is_right (lnth l n) \<longrightarrow> (\<exists>m>n. is_right (lnth l m)))
          \<and> (\<forall>n. is_left (lnth l n) \<longrightarrow> (\<exists>m>n. is_left (lnth l m)))
          \<and> (\<not> lfinite l)"

lemma fair_right_ex: "fair l \<Longrightarrow> \<exists>n. is_right (lnth l n)"
  by (simp add: fair_def)

lemma fair_left_ex: "fair l \<Longrightarrow> \<exists>n. is_left (lnth l n)"
  by (simp add: fair_def)

lemma fair_morer: "fair l \<Longrightarrow> is_right (lnth l n) \<Longrightarrow> \<exists>m>n. is_right (lnth l m)"
  by (simp add: fair_def)

lemma fair_morel: "fair l \<Longrightarrow> is_left (lnth l n) \<Longrightarrow> \<exists>m>n. is_left (lnth l m)"
  by (simp add: fair_def)

definition first_left :: "('a + 'b) llist \<Rightarrow> 'a" where
  "first_left = Sum_Type.Suml id \<circ> lhd \<circ> ldropWhile is_right"

lemma lefts_append: "lfinite xs \<Longrightarrow> \<ll> (lappend xs ys) = lappend (\<ll> xs) (\<ll> ys)"
  apply (auto simp add: lefts_def)
  by (metis lmap_lappend_distrib)

lemma rights_append: "lfinite xs \<Longrightarrow> \<rr> (lappend xs ys) = lappend (\<rr> xs) (\<rr> ys)"
  apply (auto simp add: rights_def)
  by (metis lmap_lappend_distrib)

declare in_lset_conv_lnth[iff]
declare lfinite_conv_llength_enat[iff]

lemma lnth_in_lset: "\<not> lfinite xs \<Longrightarrow> lnth xs n \<in> lset xs"
  by auto

lemma fair_ltakel: "fair xs \<Longrightarrow> lfinite (ltakeWhile is_left xs)"
  apply (subst lfinite_ltakeWhile)
  apply (rule disjI2)
  apply (auto simp add: fair_def)
  apply (rule_tac x = "lnth xs n" in bexI)
  apply assumption
  by (metis llength_eq_infty_conv_lfinite lnth_in_lset)

lemma fair_ltaker: "fair xs \<Longrightarrow> lfinite (ltakeWhile is_right xs)"
  apply (subst lfinite_ltakeWhile)
  apply (rule disjI2)
  apply (auto simp add: fair_def)
  apply (rule_tac x = "lnth xs na" in bexI)
  apply assumption
  by (metis llength_eq_infty_conv_lfinite lnth_in_lset)

lemma lefts_Nil: "lfinite xs \<Longrightarrow> \<forall>x\<in>lset xs. is_right x \<Longrightarrow> \<ll> xs = LNil"
  by (auto simp add: lefts_def)

lemma lefts_ltaker: "fair xs \<Longrightarrow> \<ll> (ltakeWhile is_right xs) = LNil"
  apply (rule lefts_Nil)
  apply (erule fair_ltaker)
  by (metis lset_ltakeWhileD)

lemma lefts_ldropr:
  assumes xs_fair: "fair xs" shows "\<ll> xs = \<ll> (ldropWhile is_right xs)" (is "?lhs = ?rhs")
proof -
  have "?lhs = \<ll> (lappend (ltakeWhile is_right xs) (ldropWhile is_right xs))"
    by (metis lappend_ltakeWhile_ldropWhile)
  also have "... = lappend (\<ll> (ltakeWhile is_right xs)) (\<ll> (ldropWhile is_right xs))"
    by (metis fair_ltaker lefts_append xs_fair)
  also have "... = lappend LNil (\<ll> (ldropWhile is_right xs))"
    by (metis lefts_ltaker xs_fair)
  also have "... = ?rhs"
    by (metis lappend_code(1))
  finally show ?thesis .
qed

lemma fairI:
  assumes "\<exists>n. is_right (lnth l n)" and "\<exists>n. is_left (lnth l n)"
  and "\<And>n. is_right (lnth l n) \<Longrightarrow> \<exists>m>n. is_right (lnth l m)"
  and "\<And>n. is_left (lnth l n) \<Longrightarrow> \<exists>m>n. is_left (lnth l m)"
  and "\<not> lfinite l"
  shows "fair l"
  by (insert assms) (simp add: fair_def)

lemma fair_non_empty: "fair l \<Longrightarrow> \<not> lfinite l"
  by (auto simp add: fair_def)

lemma [simp]: "is_left (swap x) = is_right x"
  by (cases x) auto

lemma is_right_swap [simp]: "is_right \<circ> swap = is_left"
  by (rule ext) (simp  add: o_def)

lemma is_left_swap [simp]: "is_left \<circ> swap = is_right"
  by (rule ext) (simp  add: o_def)

lemma [simp]: "unr (swap x) = unl x"
  by (cases x) auto

lemma [simp]: "unl (swap x) = unr x"
  by (cases x) auto

lemma unr_swap [simp]: "unr \<circ> swap = unl"
  by (rule ext) (simp  add: o_def)

lemma unl_swap [simp]: "unl \<circ> swap = unr"
  by (rule ext) (simp  add: o_def)

lemma [simp]: "\<langle>id,id\<rangle> (swap x) = \<langle>id,id\<rangle> x"
  by (cases x) auto

declare lmap.compositionality[simp]

lemma [simp]: "\<rr> (lmap swap xs) = \<ll> xs"
  by (simp add: rights_def lfilter_lmap lefts_def)

lemma [simp]: "\<ll> (lmap swap xs) = \<rr> xs"
  by (simp add: rights_def lfilter_lmap lefts_def)

lemma [simp]: "lmap \<langle>id,id\<rangle> (lmap swap xs) = lmap \<langle>id,id\<rangle> xs"
  by (simp add: o_def)

fun rbr1 :: "'a + ('b + 'c) \<Rightarrow> ('a + 'b) + 'c" where
  "rbr1 (Inl x) = Inl (Inl x)"
| "rbr1 (Inr (Inl x)) = Inl (Inr x)"
| "rbr1 (Inr (Inr x)) = Inr x"

fun rbr2 :: "('a + 'b) + 'c \<Rightarrow> 'a + ('b + 'c)" where
  "rbr2 (Inr x) = Inr (Inr x)"
| "rbr2 (Inl (Inr x)) = Inr (Inl x)"
| "rbr2 (Inl (Inl x)) = Inl x"

lemma sum3_cases1: "(\<And>x. P (Inl x)) \<Longrightarrow> (\<And>x. P (Inr (Inl x))) \<Longrightarrow> (\<And>x. P (Inr (Inr x))) \<Longrightarrow> P x"
  by (metis sumE)

lemma sum3_cases2: "(\<And>x. P (Inr x)) \<Longrightarrow> (\<And>x. P (Inl (Inl x))) \<Longrightarrow> (\<And>x. P (Inl (Inr x))) \<Longrightarrow> P x"
  by (metis sumE)

lemma [simp]: "is_left (unl (rbr1 x)) \<and> is_left (rbr1 x) \<longleftrightarrow> is_left x"
  by (rule sum3_cases1) auto

lemma [simp]: "is_left x \<Longrightarrow> unl (unl (rbr1 x)) = unl x"
  by (cases x) auto

lemma [simp]: "is_right (unl (rbr1 x)) \<and> is_left (rbr1 x) \<longleftrightarrow> is_left (unr x) \<and> is_right x"
  by (rule sum3_cases1) auto

lemma [simp]: "is_left (unr x) \<and> is_right x \<Longrightarrow> unr (unl (rbr1 x)) = unl (unr x)"
  apply (cases x)
  apply auto
  by (metis is_right.simps(1) not_is_right rbr1.simps(2) sum.exhaust unl.simps(1) unr.simps(1))

lemma [simp]: "is_right (rbr1 x) \<longleftrightarrow> is_right (unr x) \<and> is_right x"
  by (rule sum3_cases1) auto

lemma [simp]: "is_right (unr x) \<and> is_right x \<Longrightarrow> unr (rbr1 x) = unr (unr x)"
  apply (cases x)
  apply auto
  by (metis is_left.simps(1) not_is_left rbr1.simps(3) swap.cases unr.simps(1))

lemma [simp]: "is_right (unr (rbr2 x)) \<and> is_right (rbr2 x) \<longleftrightarrow> is_right x"
  by (rule sum3_cases2) auto

lemma [simp]: "is_right x \<Longrightarrow> unr (unr (rbr2 x)) = unr x"
  by (cases x) auto

lemma [simp]: "is_left (unr (rbr2 x)) \<and> is_right (rbr2 x) \<longleftrightarrow> is_right (unl x) \<and> is_left x"
  by (rule sum3_cases2) auto

lemma [simp]: "is_right (unl x) \<and> is_left x \<Longrightarrow> unl (unr (rbr2 x)) = unr (unl x)"
  apply (cases x)
  apply auto
  by (metis is_left.simps(1) not_is_right rbr2.simps(2) sum.exhaust unl.simps(1) unr.simps(1))

lemma [simp]: "is_left (rbr2 x) \<longleftrightarrow> is_left (unl x) \<and> is_left x"
  by (rule sum3_cases2) auto

lemma [simp]: "is_left (unl x) \<and> is_left x \<Longrightarrow> unl (rbr2 x) = unl (unl x)"
  apply (cases x)
  apply auto
  by (metis is_left.simps(2) rbr2.simps(3) sum.exhaust unl.simps(1))

lemma lmap_lfilter_eq [intro]: "(\<And>x. P x \<Longrightarrow> f x = g x) \<Longrightarrow> lmap f (lfilter P xs) = lmap g (lfilter P xs)"
  by (rule llist.map_cong0) simp

lemma lmap_lfilter_left_eq: "(\<And>x. f (Inl x) = g (Inl x)) \<Longrightarrow> lmap f (lfilter is_left xs) = lmap g (lfilter is_left xs)"
  by (rule lmap_lfilter_eq) (metis (full_types) is_left.simps(2) swap.cases)

lemma lmap_lfilter_right_eq: "(\<And>x. f (Inr x) = g (Inr x)) \<Longrightarrow> lmap f (lfilter is_right xs) = lmap g (lfilter is_right xs)"
  by (rule lmap_lfilter_eq) (metis (full_types) is_right.simps(2) swap.cases)

lemma [simp]: "\<ll> (\<ll> (lmap rbr1 xs)) = \<ll> xs"
  by (auto simp add: lefts_def lfilter_lmap  lfilter_lfilter o_def)

lemma [simp]: "\<rr> (\<ll> (lmap rbr1 xs)) = \<ll> (\<rr> xs)"
  by (auto simp add: rights_def lefts_def lfilter_lmap lfilter_lfilter o_def)

lemma [simp]: "\<rr> (lmap rbr1 xs) = \<rr> (\<rr> xs)"
  by (auto simp add: rights_def lfilter_lmap  lfilter_lfilter o_def)

lemma [simp]: "\<rr> (\<rr> (lmap rbr2 xs)) = \<rr> xs"
  by (auto simp add: rights_def lfilter_lmap  lfilter_lfilter o_def)

lemma [simp]: "\<ll> (\<rr> (lmap rbr2 xs)) = \<rr> (\<ll> xs)"
  by (auto simp add: rights_def lefts_def lfilter_lmap lfilter_lfilter o_def)

lemma [simp]: "\<ll> (lmap rbr2 xs) = \<ll> (\<ll> xs)"
  by (auto simp add: lefts_def lfilter_lmap lfilter_lfilter o_def)

lemma [simp]: "\<langle>id,\<langle>id,id\<rangle>\<rangle> (rbr2 x) = \<langle>\<langle>id,id\<rangle>,id\<rangle> x"
  by (rule sum3_cases2) auto

lemma [simp]: "\<langle>\<langle>id,id\<rangle>,id\<rangle> (rbr1 x) = \<langle>id,\<langle>id,id\<rangle>\<rangle> x"
  by (rule sum3_cases1) auto

lemma lfilter_ltakeWhile [simp]: "lfilter P (ltakeWhile (Not \<circ> P) xs) = LNil"
  by auto (metis lfilter_empty_conv lset_ltakeWhileD)

lemma lset_ex_lnth: "(\<exists>x\<in>lset xs. P x) \<Longrightarrow> \<exists>n. P (lnth xs n)"
  by auto

lemma infinite_lfilter: "\<not> lfinite (lfilter P xs) \<Longrightarrow> \<exists>n. P (lnth xs n)"
proof -
  assume "\<not> lfinite (lfilter P xs)"
  hence assm1: "\<not> lfinite (lfilter P (lappend (ltakeWhile (Not \<circ> P) xs) (ldropWhile (Not \<circ> P) xs)))"
    by (metis lappend_ltakeWhile_ldropWhile)
  {
    assume assm2: "lfinite (ltakeWhile (Not \<circ> P) xs)"
    then obtain n where n_def: "llength (ltakeWhile (Not \<circ> P) xs) = enat n"
      by (metis lfinite_conv_llength_enat)
    from assm1 and assm2
    have "\<not> lfinite (lappend (lfilter P (ltakeWhile (Not \<circ> P) xs)) (lfilter P (ldropWhile (Not \<circ> P) xs)))"
      by (metis lfilter_lappend_lfinite)
    hence "\<not> lfinite (lfilter P (ldropWhile (Not \<circ> P) xs))"
      by (simp only: lfilter_ltakeWhile, simp)
    hence "P (lhd (ldropWhile (Not \<circ> P) xs))"
      by (metis assm2 lappend_ltakeWhile_ldropWhile lfilter_eq_LConsD lfilter_lappend_lfinite lhd_LCons_ltl lhd_lfilter lnull_imp_lfinite lnull_lappend)
    hence "\<exists>x\<in>lset xs. P x"
      apply (rule_tac x = "lhd (ldropWhile (Not \<circ> P) xs)" in bexI)
      apply simp
      by (metis `\<not> lfinite (lfilter P xs)` assm2 lfinite_lfilterI lfinite_ltakeWhile lhd_ldropWhile_in_lset)
    hence "\<exists>n. P (lnth xs n)"
      by (rule lset_ex_lnth)
  }
  moreover
  {
    assume assm2: "\<not> lfinite (ltakeWhile (Not \<circ> P) xs)"
    from assm1 and assm2
    have "\<not> lfinite (lfilter P (ltakeWhile (Not \<circ> P) xs))"
      by (metis lappend_inf)
    hence "\<not> lfinite LNil"
      by (simp only: lfilter_ltakeWhile, simp)
    from this and lfinite_LNil have "False" by blast
  }
  ultimately show "\<exists>n. P (lnth xs n)"
    by metis
qed

declare in_lset_conv_lnth[iff del]
declare lfinite_conv_llength_enat[iff del]

definition "llist_Case \<equiv> case_llist"

primrec ldeleteLeft_nat :: "nat \<Rightarrow> ('a + 'b) llist \<Rightarrow> ('a + 'b) llist" where
  "ldeleteLeft_nat 0 xs = lappend (ltakeWhile is_right xs) (ltl (ldropWhile is_right xs))"
| "ldeleteLeft_nat (Suc n) xs = lappend (ltakeWhile is_right xs) (llist_Case LNil (\<lambda>x' xs'. LCons x' (ldeleteLeft_nat n xs')) (ldropWhile is_right xs))"

primrec ldeleteLeft :: "enat \<Rightarrow> ('a + 'b) llist \<Rightarrow> ('a + 'b) llist" where
  "ldeleteLeft (enat n) xs = ldeleteLeft_nat n xs"
| "ldeleteLeft \<infinity> xs = xs"

primrec linsertLeft_nat :: "nat \<Rightarrow> 'a \<Rightarrow> ('a + 'b) llist \<Rightarrow> ('a + 'b) llist" where
  "linsertLeft_nat 0 x xs = lappend (ltakeWhile is_right xs) (LCons (Inl x) (ldropWhile is_right xs))"
| "linsertLeft_nat (Suc n) x xs = lappend (ltakeWhile is_right xs) (llist_Case LNil (\<lambda>x' xs'. LCons x' (linsertLeft_nat n x xs')) (ldropWhile is_right xs))"

primrec linsertLeft :: "enat \<Rightarrow> 'a \<Rightarrow> ('a + 'b) llist \<Rightarrow> ('a + 'b) llist" where
  "linsertLeft (enat n) x xs = linsertLeft_nat n x xs"
| "linsertLeft \<infinity> x xs = xs"

lemma [simp]: "(case xs of LNil \<Rightarrow> LNil | LCons x' xs' \<Rightarrow> LCons x' xs') = xs"
  by (cases xs) auto

lemma linsertLeft_eSuc: "linsertLeft (eSuc n) x xs = lappend (ltakeWhile is_right xs) (llist_Case LNil (\<lambda>x' xs'. LCons x' (linsertLeft n x xs')) (ldropWhile is_right xs))"
  by (cases n) (simp_all add: eSuc_enat llist_Case_def)

primrec linsert_nat :: "nat \<Rightarrow> 'a \<Rightarrow> 'a llist \<Rightarrow> 'a llist" where
  "linsert_nat 0 x xs = LCons x xs"
| "linsert_nat (Suc n) x xs = llist_Case LNil (\<lambda>x' xs'. LCons x' (linsert_nat n x xs')) xs"

primrec linsert :: "enat \<Rightarrow> 'a \<Rightarrow> 'a llist \<Rightarrow> 'a llist" where
  "linsert (enat n) x xs = linsert_nat n x xs"
| "linsert \<infinity> x xs = xs"

lemma [simp]: "llength xs = \<infinity> \<Longrightarrow> lappend xs ys = xs"
  by (metis lappend_inf llength_eq_infty_conv_lfinite)

notation ltake ("\<up>")
  and ldrop ("\<down>")

lemma [simp]: "\<up> (llength xs) xs = xs"
  by (metis ltake_all order_refl)

lemma lefts_ltake_right [simp]: "\<ll> (ltakeWhile is_right xs) = LNil"
  by (metis Not_is_left comp_apply lefts_def lfilter_ltakeWhile llist.simps(12))

lemma [simp]: "lmap f xs \<noteq> LNil \<longleftrightarrow> xs \<noteq> LNil"
  by (metis lmap_eq_LNil)

end


theory GenEnv
  imports Main
begin

datatype res_id = Var string | Loc string

type_synonym ('a, 'b) gen_env = "'b \<Rightarrow> 'a option"

type_synonym 'a res_env = "('a, res_id) gen_env"

type_synonym 'a state_env = "('a, string) gen_env"

definition empty_env where
  "empty_env x = None"

definition add_env where
  "add_env env x t = (\<lambda> x'. if x = x' then Some t else env x')"

definition rem_env where
  "rem_env env x = (\<lambda> x'. if x = x' then None else env x')"

definition fresh_var where
  "fresh_var s y = (s y = None)"

    (* #### basic add/rem lemmas #### *)

lemma almost_comm_add_env: "\<lbrakk> x \<noteq> y \<rbrakk> \<Longrightarrow> add_env (add_env env y t) x t' = add_env (add_env env x t') y t"
  apply (simp add: add_env_def)
  apply (auto)
  done

lemma double_add_env: "add_env (add_env env x t) x t' = add_env env x t'"
  apply (simp add: add_env_def)
  apply (auto)
  done

lemma ignore_rem_env: "\<lbrakk> env x = None \<rbrakk> \<Longrightarrow> env = rem_env env x"
  apply (case_tac "\<forall> x'. env x' = rem_env env x x'")
   apply (auto)
  apply (simp add: rem_env_def)
  apply (case_tac "x = x'")
   apply (auto)
  done

lemma cancel_rem_add_env: "\<lbrakk> env x = None \<rbrakk> \<Longrightarrow> env = rem_env (add_env env x t) x"
  apply (case_tac "\<forall> x'. env x' = rem_env (add_env env x t) x x'")
   apply (auto)
  apply (simp add: add_env_def)
  apply (simp add: rem_env_def)
  apply (case_tac "x = x'")
   apply (auto)
  done

lemma partial_add_rem_env: "add_env (rem_env env x) x t = add_env env x t"
  apply (case_tac "\<forall> x'. add_env (rem_env env x) x t x' = add_env env x t x'")
   apply (auto)
  apply (simp add: add_env_def)
  apply (case_tac "x = x'")
   apply (auto)
  apply (simp add: rem_env_def)
  done

lemma cancel_add_rem_env: "\<lbrakk> env x = Some y \<rbrakk> \<Longrightarrow> env = add_env (rem_env env x) x y"
  apply (case_tac "\<forall> x'. env x' = add_env (rem_env env x) x y x'")
   apply (auto)
  apply (simp add: add_env_def)
  apply (case_tac "x = x'")
   apply (auto)
  apply (simp add: rem_env_def)
  done

lemma partial_rem_add_env: "rem_env (add_env env x y) x = rem_env env x"
  apply (case_tac "\<forall> x'. rem_env (add_env env x y) x x' = rem_env env x x'")
   apply (auto)
  apply (simp add: rem_env_def)
  apply (case_tac "x = x'")
   apply (auto)
  apply (simp add: add_env_def)
  done

lemma almost_comm_add_rem_env: "\<lbrakk> x \<noteq> y \<rbrakk> \<Longrightarrow> add_env (rem_env env x) y t = rem_env (add_env env y t) x"
  apply (case_tac "\<forall> x'. add_env (rem_env env x) y t x' = rem_env (add_env env y t) x x'")
   apply (auto)
  apply (simp add: add_env_def)
  apply (simp add: rem_env_def)
  apply (case_tac "y = x'")
   apply (auto)
  apply (simp add: rem_env_def)
  apply (case_tac "x = x'")
   apply (auto)
  done

lemma double_rem_env: "rem_env (rem_env env x) x = rem_env env x"
  apply (case_tac "\<forall> y. rem_env (rem_env env x) x y = rem_env env x y")
   apply (auto)
  apply (simp add: rem_env_def)
  apply (auto)
  done

lemma almost_comm_rem_env: "\<lbrakk> x \<noteq> y \<rbrakk> \<Longrightarrow> rem_env (rem_env env x) y = rem_env (rem_env env y) x"
  apply (case_tac "\<forall> z. rem_env (rem_env env x) y z = rem_env (rem_env env y) x z")
   apply (auto)
  apply (simp add: rem_env_def)
  apply (auto)
  done

end


(*  Title:      HOL/ex/Simproc_Tests.thy
    Author:     Brian Huffman
*)

section \<open>Testing of arithmetic simprocs\<close>

theory Simproc_Tests
imports Main
begin

text \<open>
  This theory tests the various simprocs defined in \<^file>\<open>~~/src/HOL/Nat.thy\<close> and
  \<^file>\<open>~~/src/HOL/Numeral_Simprocs.thy\<close>. Many of the tests are derived from commented-out code
  originally found in \<^file>\<open>~~/src/HOL/Tools/numeral_simprocs.ML\<close>.
\<close>

subsection \<open>ML bindings\<close>

ML \<open>
  fun test ctxt ps =
    CHANGED (asm_simp_tac (put_simpset HOL_basic_ss ctxt addsimprocs ps) 1)
\<close>

subsection \<open>Cancellation simprocs from \<open>Nat.thy\<close>\<close>

notepad begin
  fix a b c d :: nat
  {
    assume "b = Suc c" have "a + b = Suc (c + a)"
      by (tactic \<open>test @{context} [@{simproc nateq_cancel_sums}]\<close>) fact
  next
    assume "b < Suc c" have "a + b < Suc (c + a)"
      by (tactic \<open>test @{context} [@{simproc natless_cancel_sums}]\<close>) fact
  next
    assume "b \<le> Suc c" have "a + b \<le> Suc (c + a)"
      by (tactic \<open>test @{context} [@{simproc natle_cancel_sums}]\<close>) fact
  next
    assume "b - Suc c = d" have "a + b - Suc (c + a) = d"
      by (tactic \<open>test @{context} [@{simproc natdiff_cancel_sums}]\<close>) fact
  }
end

schematic_goal "\<And>(y::?'b::size). size (?x::?'a::size) \<le> size y + size ?x"
  by (tactic \<open>test @{context} [@{simproc natle_cancel_sums}]\<close>) (rule le0)
(* TODO: test more simprocs with schematic variables *)

subsection \<open>Abelian group cancellation simprocs\<close>

notepad begin
  fix a b c u :: "'a::ab_group_add"
  {
    assume "(a + 0) - (b + 0) = u" have "(a + c) - (b + c) = u"
      by (tactic \<open>test @{context} [@{simproc group_cancel_diff}]\<close>) fact
  next
    assume "a + 0 = b + 0" have "a + c = b + c"
      by (tactic \<open>test @{context} [@{simproc group_cancel_eq}]\<close>) fact
  }
end
(* TODO: more tests for Groups.group_cancel_{add,diff,eq,less,le} *)

subsection \<open>\<open>int_combine_numerals\<close>\<close>

(* FIXME: int_combine_numerals often unnecessarily regroups addition
and rewrites subtraction to negation. Ideally it should behave more
like Groups.abel_cancel_sum, preserving the shape of terms as much as
possible. *)

notepad begin
  fix a b c d oo uu i j k l u v w x y z :: "'a::comm_ring_1"
  {
    assume "a + - b = u" have "(a + c) - (b + c) = u"
      by (tactic \<open>test @{context} [@{simproc int_combine_numerals}]\<close>) fact
  next
    assume "10 + (2 * l + oo) = uu"
    have "l + 2 + 2 + 2 + (l + 2) + (oo + 2) = uu"
      by (tactic \<open>test @{context} [@{simproc int_combine_numerals}]\<close>) fact
  next
    assume "-3 + (i + (j + k)) = y"
    have "(i + j + 12 + k) - 15 = y"
      by (tactic \<open>test @{context} [@{simproc int_combine_numerals}]\<close>) fact
  next
    assume "7 + (i + (j + k)) = y"
    have "(i + j + 12 + k) - 5 = y"
      by (tactic \<open>test @{context} [@{simproc int_combine_numerals}]\<close>) fact
  next
    assume "-4 * (u * v) + (2 * x + y) = w"
    have "(2*x - (u*v) + y) - v*3*u = w"
      by (tactic \<open>test @{context} [@{simproc int_combine_numerals}]\<close>) fact
  next
    assume "2 * x * u * v + y = w"
    have "(2*x*u*v + (u*v)*4 + y) - v*u*4 = w"
      by (tactic \<open>test @{context} [@{simproc int_combine_numerals}]\<close>) fact
  next
    assume "3 * (u * v) + (2 * x * u * v + y) = w"
    have "(2*x*u*v + (u*v)*4 + y) - v*u = w"
      by (tactic \<open>test @{context} [@{simproc int_combine_numerals}]\<close>) fact
  next
    assume "-3 * (u * v) + (- (x * u * v) + - y) = w"
    have "u*v - (x*u*v + (u*v)*4 + y) = w"
      by (tactic \<open>test @{context} [@{simproc int_combine_numerals}]\<close>) fact
  next
    assume "a + - c = d"
    have "a + -(b+c) + b = d"
      apply (simp only: minus_add_distrib)
      by (tactic \<open>test @{context} [@{simproc int_combine_numerals}]\<close>) fact
  next
    assume "-2 * b + (a + - c) = d"
    have "a + -(b+c) - b = d"
      apply (simp only: minus_add_distrib)
      by (tactic \<open>test @{context} [@{simproc int_combine_numerals}]\<close>) fact
  next
    assume "-7 + (i + (j + (k + (- u + - y)))) = z"
    have "(i + j + -2 + k) - (u + 5 + y) = z"
      by (tactic \<open>test @{context} [@{simproc int_combine_numerals}]\<close>) fact
  next
    assume "-27 + (i + (j + k)) = y"
    have "(i + j + -12 + k) - 15 = y"
      by (tactic \<open>test @{context} [@{simproc int_combine_numerals}]\<close>) fact
  next
    assume "27 + (i + (j + k)) = y"
    have "(i + j + 12 + k) - -15 = y"
      by (tactic \<open>test @{context} [@{simproc int_combine_numerals}]\<close>) fact
  next
    assume "3 + (i + (j + k)) = y"
    have "(i + j + -12 + k) - -15 = y"
      by (tactic \<open>test @{context} [@{simproc int_combine_numerals}]\<close>) fact
  }
end

subsection \<open>\<open>inteq_cancel_numerals\<close>\<close>

notepad begin
  fix i j k u vv w y z w' y' z' :: "'a::comm_ring_1"
  {
    assume "u = 0" have "2*u = u"
      by (tactic \<open>test @{context} [@{simproc inteq_cancel_numerals}]\<close>) fact
(* conclusion matches Rings.ring_1_no_zero_divisors_class.mult_cancel_right2 *)
  next
    assume "i + (j + k) = 3 + (u + y)"
    have "(i + j + 12 + k) = u + 15 + y"
      by (tactic \<open>test @{context} [@{simproc inteq_cancel_numerals}]\<close>) fact
  next
    assume "7 + (j + (i + k)) = y"
    have "(i + j*2 + 12 + k) = j + 5 + y"
      by (tactic \<open>test @{context} [@{simproc inteq_cancel_numerals}]\<close>) fact
  next
    assume "u + (6*z + (4*y + 6*w)) = 6*z' + (4*y' + (6*w' + vv))"
    have "2*y + 3*z + 6*w + 2*y + 3*z + 2*u = 2*y' + 3*z' + 6*w' + 2*y' + 3*z' + u + vv"
      by (tactic \<open>test @{context} [@{simproc int_combine_numerals}, @{simproc inteq_cancel_numerals}]\<close>) fact
  }
end

subsection \<open>\<open>intless_cancel_numerals\<close>\<close>

notepad begin
  fix b c i j k u y :: "'a::linordered_idom"
  {
    assume "y < 2 * b" have "y - b < b"
      by (tactic \<open>test @{context} [@{simproc intless_cancel_numerals}]\<close>) fact
  next
    assume "c + y < 4 * b" have "y - (3*b + c) < b - 2*c"
      by (tactic \<open>test @{context} [@{simproc intless_cancel_numerals}]\<close>) fact
  next
    assume "i + (j + k) < 8 + (u + y)"
    have "(i + j + -3 + k) < u + 5 + y"
      by (tactic \<open>test @{context} [@{simproc intless_cancel_numerals}]\<close>) fact
  next
    assume "9 + (i + (j + k)) < u + y"
    have "(i + j + 3 + k) < u + -6 + y"
      by (tactic \<open>test @{context} [@{simproc intless_cancel_numerals}]\<close>) fact
  }
end

subsection \<open>\<open>ring_eq_cancel_numeral_factor\<close>\<close>

notepad begin
  fix x y :: "'a::{idom,ring_char_0}"
  {
    assume "3*x = 4*y" have "9*x = 12 * y"
      by (tactic \<open>test @{context} [@{simproc ring_eq_cancel_numeral_factor}]\<close>) fact
  next
    assume "-3*x = 4*y" have "-99*x = 132 * y"
      by (tactic \<open>test @{context} [@{simproc ring_eq_cancel_numeral_factor}]\<close>) fact
  next
    assume "111*x = -44*y" have "999*x = -396 * y"
      by (tactic \<open>test @{context} [@{simproc ring_eq_cancel_numeral_factor}]\<close>) fact
  next
    assume "11*x = 9*y" have "-99*x = -81 * y"
      by (tactic \<open>test @{context} [@{simproc ring_eq_cancel_numeral_factor}]\<close>) fact
  next
    assume "2*x = y" have "-2 * x = -1 * y"
      by (tactic \<open>test @{context} [@{simproc ring_eq_cancel_numeral_factor}]\<close>) fact
  next
    assume "2*x = y" have "-2 * x = -y"
      by (tactic \<open>test @{context} [@{simproc ring_eq_cancel_numeral_factor}]\<close>) fact
  }
end

subsection \<open>\<open>int_div_cancel_numeral_factors\<close>\<close>

notepad begin
  fix x y z :: "'a::{semiring_div,comm_ring_1,ring_char_0}"
  {
    assume "(3*x) div (4*y) = z" have "(9*x) div (12*y) = z"
      by (tactic \<open>test @{context} [@{simproc int_div_cancel_numeral_factors}]\<close>) fact
  next
    assume "(-3*x) div (4*y) = z" have "(-99*x) div (132*y) = z"
      by (tactic \<open>test @{context} [@{simproc int_div_cancel_numeral_factors}]\<close>) fact
  next
    assume "(111*x) div (-44*y) = z" have "(999*x) div (-396*y) = z"
      by (tactic \<open>test @{context} [@{simproc int_div_cancel_numeral_factors}]\<close>) fact
  next
    assume "(11*x) div (9*y) = z" have "(-99*x) div (-81*y) = z"
      by (tactic \<open>test @{context} [@{simproc int_div_cancel_numeral_factors}]\<close>) fact
  next
    assume "(2*x) div y = z"
    have "(-2 * x) div (-1 * y) = z"
      by (tactic \<open>test @{context} [@{simproc int_div_cancel_numeral_factors}]\<close>) fact
  }
end

subsection \<open>\<open>ring_less_cancel_numeral_factor\<close>\<close>

notepad begin
  fix x y :: "'a::linordered_idom"
  {
    assume "3*x < 4*y" have "9*x < 12 * y"
      by (tactic \<open>test @{context} [@{simproc ring_less_cancel_numeral_factor}]\<close>) fact
  next
    assume "-3*x < 4*y" have "-99*x < 132 * y"
      by (tactic \<open>test @{context} [@{simproc ring_less_cancel_numeral_factor}]\<close>) fact
  next
    assume "111*x < -44*y" have "999*x < -396 * y"
      by (tactic \<open>test @{context} [@{simproc ring_less_cancel_numeral_factor}]\<close>) fact
  next
    assume "9*y < 11*x" have "-99*x < -81 * y"
      by (tactic \<open>test @{context} [@{simproc ring_less_cancel_numeral_factor}]\<close>) fact
  next
    assume "y < 2*x" have "-2 * x < -y"
      by (tactic \<open>test @{context} [@{simproc ring_less_cancel_numeral_factor}]\<close>) fact
  next
    assume "23*y < x" have "-x < -23 * y"
      by (tactic \<open>test @{context} [@{simproc ring_less_cancel_numeral_factor}]\<close>) fact
  }
end

subsection \<open>\<open>ring_le_cancel_numeral_factor\<close>\<close>

notepad begin
  fix x y :: "'a::linordered_idom"
  {
    assume "3*x \<le> 4*y" have "9*x \<le> 12 * y"
      by (tactic \<open>test @{context} [@{simproc ring_le_cancel_numeral_factor}]\<close>) fact
  next
    assume "-3*x \<le> 4*y" have "-99*x \<le> 132 * y"
      by (tactic \<open>test @{context} [@{simproc ring_le_cancel_numeral_factor}]\<close>) fact
  next
    assume "111*x \<le> -44*y" have "999*x \<le> -396 * y"
      by (tactic \<open>test @{context} [@{simproc ring_le_cancel_numeral_factor}]\<close>) fact
  next
    assume "9*y \<le> 11*x" have "-99*x \<le> -81 * y"
      by (tactic \<open>test @{context} [@{simproc ring_le_cancel_numeral_factor}]\<close>) fact
  next
    assume "y \<le> 2*x" have "-2 * x \<le> -1 * y"
      by (tactic \<open>test @{context} [@{simproc ring_le_cancel_numeral_factor}]\<close>) fact
  next
    assume "23*y \<le> x" have "-x \<le> -23 * y"
      by (tactic \<open>test @{context} [@{simproc ring_le_cancel_numeral_factor}]\<close>) fact
  next
    assume "y \<le> 0" have "0 \<le> y * -2"
      by (tactic \<open>test @{context} [@{simproc ring_le_cancel_numeral_factor}]\<close>) fact
  next
    assume "- x \<le> y" have "- (2 * x) \<le> 2*y"
      by (tactic \<open>test @{context} [@{simproc ring_le_cancel_numeral_factor}]\<close>) fact
  }
end

subsection \<open>\<open>divide_cancel_numeral_factor\<close>\<close>

notepad begin
  fix x y z :: "'a::{field,ring_char_0}"
  {
    assume "(3*x) / (4*y) = z" have "(9*x) / (12 * y) = z"
      by (tactic \<open>test @{context} [@{simproc divide_cancel_numeral_factor}]\<close>) fact
  next
    assume "(-3*x) / (4*y) = z" have "(-99*x) / (132 * y) = z"
      by (tactic \<open>test @{context} [@{simproc divide_cancel_numeral_factor}]\<close>) fact
  next
    assume "(111*x) / (-44*y) = z" have "(999*x) / (-396 * y) = z"
      by (tactic \<open>test @{context} [@{simproc divide_cancel_numeral_factor}]\<close>) fact
  next
    assume "(11*x) / (9*y) = z" have "(-99*x) / (-81 * y) = z"
      by (tactic \<open>test @{context} [@{simproc divide_cancel_numeral_factor}]\<close>) fact
  next
    assume "(2*x) / y = z" have "(-2 * x) / (-1 * y) = z"
      by (tactic \<open>test @{context} [@{simproc divide_cancel_numeral_factor}]\<close>) fact
  }
end

subsection \<open>\<open>ring_eq_cancel_factor\<close>\<close>

notepad begin
  fix a b c d k x y :: "'a::idom"
  {
    assume "k = 0 \<or> x = y" have "x*k = k*y"
      by (tactic \<open>test @{context} [@{simproc ring_eq_cancel_factor}]\<close>) fact
  next
    assume "k = 0 \<or> 1 = y" have "k = k*y"
      by (tactic \<open>test @{context} [@{simproc ring_eq_cancel_factor}]\<close>) fact
  next
    assume "b = 0 \<or> a*c = 1" have "a*(b*c) = b"
      by (tactic \<open>test @{context} [@{simproc ring_eq_cancel_factor}]\<close>) fact
  next
    assume "a = 0 \<or> b = 0 \<or> c = d*x" have "a*(b*c) = d*b*(x*a)"
      by (tactic \<open>test @{context} [@{simproc ring_eq_cancel_factor}]\<close>) fact
  next
    assume "k = 0 \<or> x = y" have "x*k = k*y"
      by (tactic \<open>test @{context} [@{simproc ring_eq_cancel_factor}]\<close>) fact
  next
    assume "k = 0 \<or> 1 = y" have "k = k*y"
      by (tactic \<open>test @{context} [@{simproc ring_eq_cancel_factor}]\<close>) fact
  }
end

subsection \<open>\<open>int_div_cancel_factor\<close>\<close>

notepad begin
  fix a b c d k uu x y :: "'a::semiring_div"
  {
    assume "(if k = 0 then 0 else x div y) = uu"
    have "(x*k) div (k*y) = uu"
      by (tactic \<open>test @{context} [@{simproc int_div_cancel_factor}]\<close>) fact
  next
    assume "(if k = 0 then 0 else 1 div y) = uu"
    have "(k) div (k*y) = uu"
      by (tactic \<open>test @{context} [@{simproc int_div_cancel_factor}]\<close>) fact
  next
    assume "(if b = 0 then 0 else a * c) = uu"
    have "(a*(b*c)) div b = uu"
      by (tactic \<open>test @{context} [@{simproc int_div_cancel_factor}]\<close>) fact
  next
    assume "(if a = 0 then 0 else if b = 0 then 0 else c div (d * x)) = uu"
    have "(a*(b*c)) div (d*b*(x*a)) = uu"
      by (tactic \<open>test @{context} [@{simproc int_div_cancel_factor}]\<close>) fact
  }
end

lemma shows "a*(b*c)/(y*z) = d*(b::'a::linordered_field)*(x*a)/z"
oops \<comment> "FIXME: need simproc to cover this case"

subsection \<open>\<open>divide_cancel_factor\<close>\<close>

notepad begin
  fix a b c d k uu x y :: "'a::field"
  {
    assume "(if k = 0 then 0 else x / y) = uu"
    have "(x*k) / (k*y) = uu"
      by (tactic \<open>test @{context} [@{simproc divide_cancel_factor}]\<close>) fact
  next
    assume "(if k = 0 then 0 else 1 / y) = uu"
    have "(k) / (k*y) = uu"
      by (tactic \<open>test @{context} [@{simproc divide_cancel_factor}]\<close>) fact
  next
    assume "(if b = 0 then 0 else a * c) = uu"
    have "(a*(b*c)) / b = uu"
      by (tactic \<open>test @{context} [@{simproc divide_cancel_factor}]\<close>) fact
  next
    assume "(if a = 0 then 0 else if b = 0 then 0 else c / (d * x)) = uu"
    have "(a*(b*c)) / (d*b*(x*a)) = uu"
      by (tactic \<open>test @{context} [@{simproc divide_cancel_factor}]\<close>) fact
  }
end

lemma
  fixes a b c d x y z :: "'a::linordered_field"
  shows "a*(b*c)/(y*z) = d*(b)*(x*a)/z"
oops \<comment> "FIXME: need simproc to cover this case"

subsection \<open>\<open>linordered_ring_less_cancel_factor\<close>\<close>

notepad begin
  fix x y z :: "'a::linordered_idom"
  {
    assume "0 < z \<Longrightarrow> x < y" have "0 < z \<Longrightarrow> x*z < y*z"
      by (tactic \<open>test @{context} [@{simproc linordered_ring_less_cancel_factor}]\<close>) fact
  next
    assume "0 < z \<Longrightarrow> x < y" have "0 < z \<Longrightarrow> x*z < z*y"
      by (tactic \<open>test @{context} [@{simproc linordered_ring_less_cancel_factor}]\<close>) fact
  next
    assume "0 < z \<Longrightarrow> x < y" have "0 < z \<Longrightarrow> z*x < y*z"
      by (tactic \<open>test @{context} [@{simproc linordered_ring_less_cancel_factor}]\<close>) fact
  next
    assume "0 < z \<Longrightarrow> x < y" have "0 < z \<Longrightarrow> z*x < z*y"
      by (tactic \<open>test @{context} [@{simproc linordered_ring_less_cancel_factor}]\<close>) fact
  next
    txt "This simproc now uses the simplifier to prove that terms to
      be canceled are positive/negative."
    assume z_pos: "0 < z"
    assume "x < y" have "z*x < z*y"
      by (tactic \<open>CHANGED (asm_simp_tac (put_simpset HOL_basic_ss @{context}
        addsimprocs [@{simproc linordered_ring_less_cancel_factor}]
        addsimps [@{thm z_pos}]) 1)\<close>) fact
  }
end

subsection \<open>\<open>linordered_ring_le_cancel_factor\<close>\<close>

notepad begin
  fix x y z :: "'a::linordered_idom"
  {
    assume "0 < z \<Longrightarrow> x \<le> y" have "0 < z \<Longrightarrow> x*z \<le> y*z"
      by (tactic \<open>test @{context} [@{simproc linordered_ring_le_cancel_factor}]\<close>) fact
  next
    assume "0 < z \<Longrightarrow> x \<le> y" have "0 < z \<Longrightarrow> z*x \<le> z*y"
      by (tactic \<open>test @{context} [@{simproc linordered_ring_le_cancel_factor}]\<close>) fact
  }
end

subsection \<open>\<open>field_combine_numerals\<close>\<close>

notepad begin
  fix x y z uu :: "'a::{field,ring_char_0}"
  {
    assume "5 / 6 * x = uu" have "x / 2 + x / 3 = uu"
      by (tactic \<open>test @{context} [@{simproc field_combine_numerals}]\<close>) fact
  next
    assume "6 / 9 * x + y = uu" have "x / 3 + y + x / 3 = uu"
      by (tactic \<open>test @{context} [@{simproc field_combine_numerals}]\<close>) fact
  next
    assume "9 / 9 * x = uu" have "2 * x / 3 + x / 3 = uu"
      by (tactic \<open>test @{context} [@{simproc field_combine_numerals}]\<close>) fact
  next
    assume "y + z = uu"
    have "x / 2 + y - 3 * x / 6 + z = uu"
      by (tactic \<open>test @{context} [@{simproc field_combine_numerals}]\<close>) fact
  next
    assume "1 / 15 * x + y = uu"
    have "7 * x / 5 + y - 4 * x / 3 = uu"
      by (tactic \<open>test @{context} [@{simproc field_combine_numerals}]\<close>) fact
  }
end

lemma
  fixes x :: "'a::{linordered_field}"
  shows "2/3 * x + x / 3 = uu"
apply (tactic \<open>test @{context} [@{simproc field_combine_numerals}]\<close>)?
oops \<comment> "FIXME: test fails"

subsection \<open>\<open>nat_combine_numerals\<close>\<close>

notepad begin
  fix i j k m n u :: nat
  {
    assume "4*k = u" have "k + 3*k = u"
      by (tactic \<open>test @{context} [@{simproc nat_combine_numerals}]\<close>) fact
  next
    (* FIXME "Suc (i + 3) \<equiv> i + 4" *)
    assume "4 * Suc 0 + i = u" have "Suc (i + 3) = u"
      by (tactic \<open>test @{context} [@{simproc nat_combine_numerals}]\<close>) fact
  next
    (* FIXME "Suc (i + j + 3 + k) \<equiv> i + j + 4 + k" *)
    assume "4 * Suc 0 + (i + (j + k)) = u" have "Suc (i + j + 3 + k) = u"
      by (tactic \<open>test @{context} [@{simproc nat_combine_numerals}]\<close>) fact
  next
    assume "2 * j + 4 * k = u" have "k + j + 3*k + j = u"
      by (tactic \<open>test @{context} [@{simproc nat_combine_numerals}]\<close>) fact
  next
    assume "6 * Suc 0 + (5 * (i * j) + (4 * k + i)) = u"
    have "Suc (j*i + i + k + 5 + 3*k + i*j*4) = u"
      by (tactic \<open>test @{context} [@{simproc nat_combine_numerals}]\<close>) fact
  next
    assume "5 * (m * n) = u" have "(2*n*m) + (3*(m*n)) = u"
      by (tactic \<open>test @{context} [@{simproc nat_combine_numerals}]\<close>) fact
  }
end

subsection \<open>\<open>nateq_cancel_numerals\<close>\<close>

notepad begin
  fix i j k l oo u uu vv w y z w' y' z' :: "nat"
  {
    assume "Suc 0 * u = 0" have "2*u = (u::nat)"
      by (tactic \<open>test @{context} [@{simproc nateq_cancel_numerals}]\<close>) fact
  next
    assume "Suc 0 * u = Suc 0" have "2*u = Suc (u)"
      by (tactic \<open>test @{context} [@{simproc nateq_cancel_numerals}]\<close>) fact
  next
    assume "i + (j + k) = 3 * Suc 0 + (u + y)"
    have "(i + j + 12 + k) = u + 15 + y"
      by (tactic \<open>test @{context} [@{simproc nateq_cancel_numerals}]\<close>) fact
  next
    assume "7 * Suc 0 + (i + (j + k)) = u + y"
    have "(i + j + 12 + k) = u + 5 + y"
      by (tactic \<open>test @{context} [@{simproc nateq_cancel_numerals}]\<close>) fact
  next
    assume "11 * Suc 0 + (i + (j + k)) = u + y"
    have "(i + j + 12 + k) = Suc (u + y)"
      by (tactic \<open>test @{context} [@{simproc nateq_cancel_numerals}]\<close>) fact
  next
    assume "i + (j + k) = 2 * Suc 0 + (u + y)"
    have "(i + j + 5 + k) = Suc (Suc (Suc (Suc (Suc (Suc (Suc (u + y)))))))"
      by (tactic \<open>test @{context} [@{simproc nateq_cancel_numerals}]\<close>) fact
  next
    assume "Suc 0 * u + (2 * y + 3 * z) = Suc 0"
    have "2*y + 3*z + 2*u = Suc (u)"
      by (tactic \<open>test @{context} [@{simproc nateq_cancel_numerals}]\<close>) fact
  next
    assume "Suc 0 * u + (2 * y + (3 * z + (6 * w + (2 * y + 3 * z)))) = Suc 0"
    have "2*y + 3*z + 6*w + 2*y + 3*z + 2*u = Suc (u)"
      by (tactic \<open>test @{context} [@{simproc nateq_cancel_numerals}]\<close>) fact
  next
    assume "Suc 0 * u + (2 * y + (3 * z + (6 * w + (2 * y + 3 * z)))) =
      2 * y' + (3 * z' + (6 * w' + (2 * y' + (3 * z' + vv))))"
    have "2*y + 3*z + 6*w + 2*y + 3*z + 2*u =
      2*y' + 3*z' + 6*w' + 2*y' + 3*z' + u + vv"
      by (tactic \<open>test @{context} [@{simproc nateq_cancel_numerals}]\<close>) fact
  next
    assume "2 * u + (2 * z + (5 * Suc 0 + 2 * y)) = vv"
    have "6 + 2*y + 3*z + 4*u = Suc (vv + 2*u + z)"
      by (tactic \<open>test @{context} [@{simproc nateq_cancel_numerals}]\<close>) fact
  }
end

subsection \<open>\<open>natless_cancel_numerals\<close>\<close>

notepad begin
  fix length :: "'a \<Rightarrow> nat" and l1 l2 xs :: "'a" and f :: "nat \<Rightarrow> 'a"
  fix c i j k l m oo u uu vv w y z w' y' z' :: "nat"
  {
    assume "0 < j" have "(2*length xs < 2*length xs + j)"
      by (tactic \<open>test @{context} [@{simproc natless_cancel_numerals}]\<close>) fact
  next
    assume "0 < j" have "(2*length xs < length xs * 2 + j)"
      by (tactic \<open>test @{context} [@{simproc natless_cancel_numerals}]\<close>) fact
  next
    assume "i + (j + k) < u + y"
    have "(i + j + 5 + k) < Suc (Suc (Suc (Suc (Suc (u + y)))))"
      by (tactic \<open>test @{context} [@{simproc natless_cancel_numerals}]\<close>) fact
  next
    assume "0 < Suc 0 * (m * n) + u" have "(2*n*m) < (3*(m*n)) + u"
      by (tactic \<open>test @{context} [@{simproc natless_cancel_numerals}]\<close>) fact
  }
end

subsection \<open>\<open>natle_cancel_numerals\<close>\<close>

notepad begin
  fix length :: "'a \<Rightarrow> nat" and l2 l3 :: "'a" and f :: "nat \<Rightarrow> 'a"
  fix c e i j k l oo u uu vv w y z w' y' z' :: "nat"
  {
    assume "u + y \<le> 36 * Suc 0 + (i + (j + k))"
    have "Suc (Suc (Suc (Suc (Suc (u + y))))) \<le> ((i + j) + 41 + k)"
      by (tactic \<open>test @{context} [@{simproc natle_cancel_numerals}]\<close>) fact
  next
    assume "5 * Suc 0 + (case length (f c) of 0 \<Rightarrow> 0 | Suc k \<Rightarrow> k) = 0"
    have "(Suc (Suc (Suc (Suc (Suc (Suc (case length (f c) of 0 => 0 | Suc k => k)))))) \<le> Suc 0)"
      by (tactic \<open>test @{context} [@{simproc natle_cancel_numerals}]\<close>) fact
  next
    assume "6 + length l2 = 0" have "Suc (Suc (Suc (Suc (Suc (Suc (length l1 + length l2)))))) \<le> length l1"
      by (tactic \<open>test @{context} [@{simproc natle_cancel_numerals}]\<close>) fact
  next
    assume "5 + length l3 = 0"
    have "( (Suc (Suc (Suc (Suc (Suc (length (compT P E A ST mxr e) + length l3)))))) \<le> length (compT P E A ST mxr e))"
      by (tactic \<open>test @{context} [@{simproc natle_cancel_numerals}]\<close>) fact
  next
    assume "5 + length (compT P E (A \<union> A' e) ST mxr c) = 0"
    have "( (Suc (Suc (Suc (Suc (Suc (length (compT P E A ST mxr e) + length (compT P E (A Un A' e) ST mxr c))))))) \<le> length (compT P E A ST mxr e))"
      by (tactic \<open>test @{context} [@{simproc natle_cancel_numerals}]\<close>) fact
  }
end

subsection \<open>\<open>natdiff_cancel_numerals\<close>\<close>

notepad begin
  fix length :: "'a \<Rightarrow> nat" and l2 l3 :: "'a" and f :: "nat \<Rightarrow> 'a"
  fix c e i j k l oo u uu vv v w x y z zz w' y' z' :: "nat"
  {
    assume "i + (j + k) - 3 * Suc 0 = y" have "(i + j + 12 + k) - 15 = y"
      by (tactic \<open>test @{context} [@{simproc natdiff_cancel_numerals}]\<close>) fact
  next
    assume "7 * Suc 0 + (i + (j + k)) - 0 = y" have "(i + j + 12 + k) - 5 = y"
      by (tactic \<open>test @{context} [@{simproc natdiff_cancel_numerals}]\<close>) fact
  next
    assume "u - Suc 0 * Suc 0 = y" have "Suc u - 2 = y"
      by (tactic \<open>test @{context} [@{simproc natdiff_cancel_numerals}]\<close>) fact
  next
    assume "Suc 0 * Suc 0 + u - 0 = y" have "Suc (Suc (Suc u)) - 2 = y"
      by (tactic \<open>test @{context} [@{simproc natdiff_cancel_numerals}]\<close>) fact
  next
    assume "Suc 0 * Suc 0 + (i + (j + k)) - 0 = y"
    have "(i + j + 2 + k) - 1 = y"
      by (tactic \<open>test @{context} [@{simproc natdiff_cancel_numerals}]\<close>) fact
  next
    assume "i + (j + k) - Suc 0 * Suc 0 = y"
    have "(i + j + 1 + k) - 2 = y"
      by (tactic \<open>test @{context} [@{simproc natdiff_cancel_numerals}]\<close>) fact
  next
    assume "2 * x + y - 2 * (u * v) = w"
    have "(2*x + (u*v) + y) - v*3*u = w"
      by (tactic \<open>test @{context} [@{simproc natdiff_cancel_numerals}]\<close>) fact
  next
    assume "2 * x * u * v + (5 + y) - 0 = w"
    have "(2*x*u*v + 5 + (u*v)*4 + y) - v*u*4 = w"
      by (tactic \<open>test @{context} [@{simproc natdiff_cancel_numerals}]\<close>) fact
  next
    assume "3 * (u * v) + (2 * x * u * v + y) - 0 = w"
    have "(2*x*u*v + (u*v)*4 + y) - v*u = w"
      by (tactic \<open>test @{context} [@{simproc natdiff_cancel_numerals}]\<close>) fact
  next
    assume "3 * u + (2 + (2 * x * u * v + y)) - 0 = w"
    have "Suc (Suc (2*x*u*v + u*4 + y)) - u = w"
      by (tactic \<open>test @{context} [@{simproc natdiff_cancel_numerals}]\<close>) fact
  next
    assume "Suc (Suc 0 * (u * v)) - 0 = w"
    have "Suc ((u*v)*4) - v*3*u = w"
      by (tactic \<open>test @{context} [@{simproc natdiff_cancel_numerals}]\<close>) fact
  next
    assume "2 - 0 = w" have "Suc (Suc ((u*v)*3)) - v*3*u = w"
      by (tactic \<open>test @{context} [@{simproc natdiff_cancel_numerals}]\<close>) fact
  next
    assume "17 * Suc 0 + (i + (j + k)) - (u + y) = zz"
    have "(i + j + 32 + k) - (u + 15 + y) = zz"
      by (tactic \<open>test @{context} [@{simproc natdiff_cancel_numerals}]\<close>) fact
  next
    assume "u + y - 0 = v" have "Suc (Suc (Suc (Suc (Suc (u + y))))) - 5 = v"
      by (tactic \<open>test @{context} [@{simproc natdiff_cancel_numerals}]\<close>) fact
  }
end

subsection \<open>Factor-cancellation simprocs for type @{typ nat}\<close>

text \<open>\<open>nat_eq_cancel_factor\<close>, \<open>nat_less_cancel_factor\<close>,
\<open>nat_le_cancel_factor\<close>, \<open>nat_divide_cancel_factor\<close>, and
\<open>nat_dvd_cancel_factor\<close>.\<close>

notepad begin
  fix a b c d k x y uu :: nat
  {
    assume "k = 0 \<or> x = y" have "x*k = k*y"
      by (tactic \<open>test @{context} [@{simproc nat_eq_cancel_factor}]\<close>) fact
  next
    assume "k = 0 \<or> Suc 0 = y" have "k = k*y"
      by (tactic \<open>test @{context} [@{simproc nat_eq_cancel_factor}]\<close>) fact
  next
    assume "b = 0 \<or> a * c = Suc 0" have "a*(b*c) = b"
      by (tactic \<open>test @{context} [@{simproc nat_eq_cancel_factor}]\<close>) fact
  next
    assume "a = 0 \<or> b = 0 \<or> c = d * x" have "a*(b*c) = d*b*(x*a)"
      by (tactic \<open>test @{context} [@{simproc nat_eq_cancel_factor}]\<close>) fact
  next
    assume "0 < k \<and> x < y" have "x*k < k*y"
      by (tactic \<open>test @{context} [@{simproc nat_less_cancel_factor}]\<close>) fact
  next
    assume "0 < k \<and> Suc 0 < y" have "k < k*y"
      by (tactic \<open>test @{context} [@{simproc nat_less_cancel_factor}]\<close>) fact
  next
    assume "0 < b \<and> a * c < Suc 0" have "a*(b*c) < b"
      by (tactic \<open>test @{context} [@{simproc nat_less_cancel_factor}]\<close>) fact
  next
    assume "0 < a \<and> 0 < b \<and> c < d * x" have "a*(b*c) < d*b*(x*a)"
      by (tactic \<open>test @{context} [@{simproc nat_less_cancel_factor}]\<close>) fact
  next
    assume "0 < k \<longrightarrow> x \<le> y" have "x*k \<le> k*y"
      by (tactic \<open>test @{context} [@{simproc nat_le_cancel_factor}]\<close>) fact
  next
    assume "0 < k \<longrightarrow> Suc 0 \<le> y" have "k \<le> k*y"
      by (tactic \<open>test @{context} [@{simproc nat_le_cancel_factor}]\<close>) fact
  next
    assume "0 < b \<longrightarrow> a * c \<le> Suc 0" have "a*(b*c) \<le> b"
      by (tactic \<open>test @{context} [@{simproc nat_le_cancel_factor}]\<close>) fact
  next
    assume "0 < a \<longrightarrow> 0 < b \<longrightarrow> c \<le> d * x" have "a*(b*c) \<le> d*b*(x*a)"
      by (tactic \<open>test @{context} [@{simproc nat_le_cancel_factor}]\<close>) fact
  next
    assume "(if k = 0 then 0 else x div y) = uu" have "(x*k) div (k*y) = uu"
      by (tactic \<open>test @{context} [@{simproc nat_div_cancel_factor}]\<close>) fact
  next
    assume "(if k = 0 then 0 else Suc 0 div y) = uu" have "k div (k*y) = uu"
      by (tactic \<open>test @{context} [@{simproc nat_div_cancel_factor}]\<close>) fact
  next
    assume "(if b = 0 then 0 else a * c) = uu" have "(a*(b*c)) div (b) = uu"
      by (tactic \<open>test @{context} [@{simproc nat_div_cancel_factor}]\<close>) fact
  next
    assume "(if a = 0 then 0 else if b = 0 then 0 else c div (d * x)) = uu"
    have "(a*(b*c)) div (d*b*(x*a)) = uu"
      by (tactic \<open>test @{context} [@{simproc nat_div_cancel_factor}]\<close>) fact
  next
    assume "k = 0 \<or> x dvd y" have "(x*k) dvd (k*y)"
      by (tactic \<open>test @{context} [@{simproc nat_dvd_cancel_factor}]\<close>) fact
  next
    assume "k = 0 \<or> Suc 0 dvd y" have "k dvd (k*y)"
      by (tactic \<open>test @{context} [@{simproc nat_dvd_cancel_factor}]\<close>) fact
  next
    assume "b = 0 \<or> a * c dvd Suc 0" have "(a*(b*c)) dvd (b)"
      by (tactic \<open>test @{context} [@{simproc nat_dvd_cancel_factor}]\<close>) fact
  next
    assume "b = 0 \<or> Suc 0 dvd a * c" have "b dvd (a*(b*c))"
      by (tactic \<open>test @{context} [@{simproc nat_dvd_cancel_factor}]\<close>) fact
  next
    assume "a = 0 \<or> b = 0 \<or> c dvd d * x" have "(a*(b*c)) dvd (d*b*(x*a))"
      by (tactic \<open>test @{context} [@{simproc nat_dvd_cancel_factor}]\<close>) fact
  }
end

subsection \<open>Numeral-cancellation simprocs for type @{typ nat}\<close>

notepad begin
  fix x y z :: nat
  {
    assume "3 * x = 4 * y" have "9*x = 12 * y"
      by (tactic \<open>test @{context} [@{simproc nat_eq_cancel_numeral_factor}]\<close>) fact
  next
    assume "3 * x < 4 * y" have "9*x < 12 * y"
      by (tactic \<open>test @{context} [@{simproc nat_less_cancel_numeral_factor}]\<close>) fact
  next
    assume "3 * x \<le> 4 * y" have "9*x \<le> 12 * y"
      by (tactic \<open>test @{context} [@{simproc nat_le_cancel_numeral_factor}]\<close>) fact
  next
    assume "(3 * x) div (4 * y) = z" have "(9*x) div (12 * y) = z"
      by (tactic \<open>test @{context} [@{simproc nat_div_cancel_numeral_factor}]\<close>) fact
  next
    assume "(3 * x) dvd (4 * y)" have "(9*x) dvd (12 * y)"
      by (tactic \<open>test @{context} [@{simproc nat_dvd_cancel_numeral_factor}]\<close>) fact
  }
end

subsection \<open>Integer numeral div/mod simprocs\<close>

notepad begin
  have "(10::int) div 3 = 3"
    by (tactic \<open>test @{context} [@{simproc numeral_divmod}]\<close>)
  have "(10::int) mod 3 = 1"
    by (tactic \<open>test @{context} [@{simproc numeral_divmod}]\<close>)
  have "(10::int) div -3 = -4"
    by (tactic \<open>test @{context} [@{simproc numeral_divmod}]\<close>)
  have "(10::int) mod -3 = -2"
    by (tactic \<open>test @{context} [@{simproc numeral_divmod}]\<close>)
  have "(-10::int) div 3 = -4"
    by (tactic \<open>test @{context} [@{simproc numeral_divmod}]\<close>)
  have "(-10::int) mod 3 = 2"
    by (tactic \<open>test @{context} [@{simproc numeral_divmod}]\<close>)
  have "(-10::int) div -3 = 3"
    by (tactic \<open>test @{context} [@{simproc numeral_divmod}]\<close>)
  have "(-10::int) mod -3 = -1"
    by (tactic \<open>test @{context} [@{simproc numeral_divmod}]\<close>)
  have "(8452::int) mod 3 = 1"
    by (tactic \<open>test @{context} [@{simproc numeral_divmod}]\<close>)
  have "(59485::int) div 434 = 137"
    by (tactic \<open>test @{context} [@{simproc numeral_divmod}]\<close>)
  have "(1000006::int) mod 10 = 6"
    by (tactic \<open>test @{context} [@{simproc numeral_divmod}]\<close>)
  have "10000000 div 2 = (5000000::int)"
    by (tactic \<open>test @{context} [@{simproc numeral_divmod}]\<close>)
  have "10000001 mod 2 = (1::int)"
    by (tactic \<open>test @{context} [@{simproc numeral_divmod}]\<close>)
  have "10000055 div 32 = (312501::int)"
    by (tactic \<open>test @{context} [@{simproc numeral_divmod}]\<close>)
  have "10000055 mod 32 = (23::int)"
    by (tactic \<open>test @{context} [@{simproc numeral_divmod}]\<close>)
  have "100094 div 144 = (695::int)"
    by (tactic \<open>test @{context} [@{simproc numeral_divmod}]\<close>)
  have "100094 mod 144 = (14::int)"
    by (tactic \<open>test @{context} [@{simproc numeral_divmod}]\<close>)
end

end


theory Aczel
  imports Language
begin

coinductive consistent :: "('a \<times> 'a) llist \<Rightarrow> bool" where
  EqNil [intro!]: "consistent LNil"
| EqSingle [intro!]: "consistent (LCons \<sigma> LNil)"
| EqPair [intro!]: "snd \<sigma> = fst \<sigma>' \<Longrightarrow> consistent (LCons \<sigma>' t) \<Longrightarrow> consistent (LCons \<sigma> (LCons \<sigma>' t))"

lemma consistent_LConsD [dest]: "consistent (LCons \<sigma> t) \<Longrightarrow> consistent t"
  by (erule consistent.cases) auto

lemma consistent_LConsE [elim]: "consistent (LCons \<sigma> (LCons \<sigma>' t)) \<Longrightarrow> snd \<sigma> = fst \<sigma>'"
  by (erule consistent.cases) auto

lemma lnth_repeat [simp]: "lnth (repeat x) n = x"
  by (induct n) simp_all

lemma inf_stutter_consistent: "consistent (repeat (\<sigma>, \<sigma>))"
proof -
  have "\<forall>n. snd (lnth (repeat (\<sigma>, \<sigma>)) n) = fst (lnth (repeat (\<sigma>, \<sigma>)) (Suc n))"
    by (simp del: lnth_iterates)
  thus ?thesis
  proof coinduct
    case (consistent t)
    show ?case
    proof (cases t)
      assume "t = LNil"
      thus ?case by simp
    next
      fix \<sigma> t'
      assume [simp]: "t = LCons \<sigma> t'"
      hence "?EqSingle \<or> ?EqPair"
      proof (cases t')
        assume "t' = LNil"
        thus "?EqSingle \<or> ?EqPair" by simp
      next
        fix \<sigma>' t''
        assume [simp]: "t' = LCons \<sigma>' t''"
        from consistent
        have "?EqPair"
          by (auto, erule_tac x = 0 in allE, auto, erule_tac x = "Suc n" in allE, auto)
        thus "?EqSingle \<or> ?EqPair" by simp
      qed
      thus ?case by simp
    qed
  qed
qed

definition Con :: "('a \<times> 'a) lan" where
  "Con = Collect consistent"

definition Aczel :: "('a \<times> 'a) lan \<Rightarrow> ('a \<times> 'a) lan" ("\<pi>") where
  "\<pi> X = X \<inter> Con"

lemma inf_stutter_Con [intro!]: "repeat (\<sigma>, \<sigma>) \<in> Con"
  by (metis Con_def inf_stutter_consistent mem_Collect_eq)

lemma Aczel_continuous: "\<pi> (\<Union>\<XX>) = \<Union>{\<pi> X |X. X \<in> \<XX>}"
  by (auto simp add: Aczel_def)

lemma Aczel_inter [simp]: "\<pi> (X \<inter> Y) = \<pi> X \<inter> \<pi> Y"
  by (metis Aczel_def Int_assoc inf_commute inf_left_idem)

lemma Aczel_union [simp]: "\<pi> (X \<union> Y) = \<pi> X \<union> \<pi> Y"
  by (auto simp add: Aczel_def)

lemma Aczel_coextensive [intro!]: "\<pi> X \<subseteq> X"
  by (auto simp add: Aczel_def)

lemma Aczel_iso [intro]: "X \<subseteq> Y \<Longrightarrow> \<pi> X \<subseteq> \<pi> Y"
  by (auto simp add: Aczel_def)

lemma Aczel_idem [simp]: "\<pi> (\<pi> X) = \<pi> X"
  by (auto simp add: Aczel_def)

lemma Aczel_zero [simp]: "\<pi> {} = {}"
  by (simp add: Aczel_def)

lemma Con_l_prod: "Con = (Con \<cdot> Con) \<inter> Con"
  by (auto simp add: Con_def l_prod_def) (metis EqNil lappend_LNil2)

lemma consistent_lappend1 [dest]:
  assumes "consistent (t \<frown> s)" shows "consistent t"
proof (cases "lfinite t")
  assume "lfinite t"
  from this and assms
  show "consistent t"
  proof (induct t rule: lfinite_induct)
    case Nil show ?case by blast
  next
    case (Cons \<sigma> t)
    thus ?case
      by (cases t) auto
  qed
next
  assume "\<not> lfinite t"
  from this and assms
  show "consistent t"
    by (metis lappend_inf)
qed

lemma consistent_lappend2 [dest]: "lfinite t \<Longrightarrow> consistent (t \<frown> s) \<Longrightarrow> consistent s"
proof (induct t rule: lfinite_induct)
  case Nil thus ?case by simp
next
  case (Cons \<sigma> t)
  thus ?case
    by (cases t) auto
qed

lemma [dest]: "xs \<frown> ys \<in> Con \<Longrightarrow> xs \<in> Con"
  by (auto simp add: Con_def)

lemma [dest]: "lfinite xs \<Longrightarrow> xs \<frown> ys \<in> Con \<Longrightarrow> ys \<in> Con"
  by (auto simp add: Con_def)

lemma [simp]: "X \<cdot> {} \<union> X \<inter> FIN = X"
  by (auto simp add: l_prod_def FIN_def)

lemma Aczel_l_prod [simp]: "\<pi> (\<pi> X \<cdot> \<pi> Y) = \<pi> (X \<cdot> Y)"
proof -
  have "\<pi> (X \<cdot> Y) = \<pi> {xs \<in> X. \<not> lfinite xs} \<union> \<pi> {xs \<frown> ys |xs ys. xs \<in> X \<and> lfinite xs \<and> ys \<in> Y}"
    by (simp add: l_prod_def)
  also have "... = \<pi> X \<cdot> {} \<union> \<pi> {xs \<frown> ys |xs ys. xs \<in> X \<and> lfinite xs \<and> ys \<in> Y}"
    by simp
  also have "... = \<pi> X \<cdot> {} \<union> \<pi> ((\<pi> X \<inter> FIN) \<cdot> \<pi> Y)"
    by (subst fin_l_prod, metis (mono_tags) inf.cobounded2, auto simp add: Aczel_def FIN_def)
  also have "... = \<pi> (\<pi> X \<cdot> {} \<union> (\<pi> X \<inter> FIN) \<cdot> \<pi> Y)"
    by (auto simp add: Aczel_def l_prod_def)
  also have "... = \<pi> (\<pi> X \<cdot> {} \<cdot> \<pi> Y \<union> (\<pi> X \<inter> FIN) \<cdot> \<pi> Y)"
    by (metis l_prod_zero seq.mult_assoc)
  also have "... = \<pi> ((\<pi> X \<cdot> {} \<union> (\<pi> X \<inter> FIN)) \<cdot> \<pi> Y)"
    by (metis l_prod_distr)
  also have "... = \<pi> (\<pi> X \<cdot> \<pi> Y)"
    by simp
  finally show ?thesis by blast
qed

lemma [simp]: "ltake \<infinity> xs = xs"
  apply (cases "lfinite xs")
  apply (induct xs rule: lfinite_induct)
  apply simp_all
  apply (subst eSuc_infinity[symmetric])
  apply (subst ltake_LCons)
  apply (simp del: eSuc_infinity)
  by (metis ltake_all not_lfinite_llength order_refl)

lemma llist_cases3:
  "P LNil \<Longrightarrow> (\<And>x. xs = LCons x LNil \<Longrightarrow> P xs) \<Longrightarrow> (\<And>x y ys. xs = LCons y (LCons x ys) \<Longrightarrow> P xs) \<Longrightarrow> P xs"
  by (metis (full_types) lhd_LCons_ltl)

lemma consistent_ltake: "consistent t \<Longrightarrow> consistent (ltake n t)"
proof (induct n, simp_all)
  fix n
  assume "consistent t"
  thus "consistent (ltake (enat n) t)"
  proof (induct n arbitrary: t)
    case 0 show ?case by (auto simp: enat_0)
  next
    case (Suc n)
    show ?case
    proof (rule llist_cases3[where xs = t])
      show "consistent (ltake (enat (Suc n)) LNil)"
        by (simp add: eSuc_enat[symmetric]) blast
    next
      fix \<sigma>
      assume "t = LCons \<sigma> LNil"
      from this and Suc.prems show "consistent (ltake (enat (Suc n)) t)"
        by (cases n) (simp_all add: enat_0 eSuc_enat[symmetric])
    next
      fix \<sigma> \<sigma>' t'
      assume "t = LCons \<sigma> (LCons \<sigma>' t')"
      from this and Suc show "consistent (ltake (enat (Suc n)) t)"
        apply (cases n)
        apply (simp_all add: eSuc_enat[symmetric] enat_0)
        apply blast
        apply (rule EqPair)
        apply (erule consistent_LConsE)
        by (metis consistent_LConsD ltake_eSuc_LCons)
    qed
  qed
qed

lemma Aczel_par: "\<pi> (\<pi> X \<parallel> \<pi> Y) \<le> \<pi> (X \<parallel> Y)"
  by (metis Aczel_coextensive Aczel_iso par.mult_isol_var)

lemma Aczel_consistent [simp]: "\<pi> X \<inter> Con = \<pi> X"
  by (simp add: Aczel_def)

lemma Aczel_UNIV [simp]: "\<pi> UNIV = Con"
  by (auto simp add: Aczel_def)

lemma lappend_consistent:
  "lfinite xs \<Longrightarrow> consistent (LCons x xs \<frown> LCons y ys) \<Longrightarrow> snd (llast (LCons x xs)) = fst y"
  by (induct xs arbitrary: x rule: lfinite_induct) auto

lemma [dest!]: "consistent (LCons x xs \<frown> LCons y ys) \<Longrightarrow> lfinite xs \<longrightarrow> snd (llast (LCons x xs)) = fst y"
  by (metis lappend_consistent)

lemma [simp]: "llast (LCons (\<sigma>, \<sigma>) (llist_of (replicate n (\<sigma>, \<sigma>)))) = (\<sigma>, \<sigma>)"
  by (induct n) auto

definition Aczel_mult :: "('a \<times> 'a) lan \<Rightarrow> ('a \<times> 'a) lan \<Rightarrow> ('a \<times> 'a) lan" (infixl "\<otimes>" 75) where
  "X \<otimes> Y = \<pi> (X \<cdot> Y)"

lemma amult_distl [simp]: "X \<otimes> (Y \<union> Z) = X \<otimes> Y \<union> X \<otimes> Z"
  by (simp add: Aczel_mult_def)

lemma amult_distr [simp]: "(X \<union> Y) \<otimes> Z = X \<otimes> Z \<union> Y \<otimes> Z"
  by (simp add: Aczel_mult_def)

lemma amult_assoc: "X \<otimes> (Y \<otimes> Z) = (X \<otimes> Y) \<otimes> Z"
  by (simp add: Aczel_mult_def) (metis Aczel_def Aczel_l_prod inf_commute inf_left_idem seq.mult_assoc)

lemma consistent_replicate': "consistent (llist_of xs) \<Longrightarrow> \<forall>y\<in>set xs. \<exists>\<sigma>. y = (\<sigma>, \<sigma>) \<Longrightarrow> \<exists>n \<sigma>. xs = replicate n (\<sigma>, \<sigma>)"
proof (induct xs)
  case Nil show ?case by simp
next
  case (Cons x1 xs)
  thus ?case
  proof (induct xs)
    case Nil thus ?case
      by (rule_tac x = 1 in exI) auto
  next
    case (Cons x2 xs)
    thus ?case
      apply -
      apply simp
      apply (frule consistent_LConsD)
      apply simp
      apply (frule consistent_LConsD) back
      apply simp
      apply auto
      apply (subgoal_tac "\<exists>n \<sigma>. xs = replicate n (\<sigma>, \<sigma>)")
      apply simp
      apply (subgoal_tac "\<sigma>'' = \<sigma>'")
      apply simp
      apply (subgoal_tac "\<sigma>' = \<sigma>")
      apply simp
      apply (rule_tac x = "Suc n" in exI)
      apply simp
      apply (metis in_set_member in_set_replicate member_rec(1) prod.inject)
      apply (drule consistent_LConsE)
      apply simp
      apply (rule_tac x = "n - 1" in exI)
      by (metis tl.simps(2) tl_replicate)
  qed
qed

lemma replicate_finite_Con: "llist_of (replicate n (\<sigma>, \<sigma>)) \<in> Con"
proof (induct n)
  case 0 show ?case
    by (auto simp add: Con_def)
next
  case (Suc n) thus ?case
    by (cases n) (auto simp add: Con_def)
qed

lemma Aczel_inf [simp]: "\<pi> (x\<cdot>{}) = (\<pi> x)\<cdot>{}"
  by (auto simp add: l_prod_def Con_def)

lemma Aczel_one [simp]: "\<pi> {LNil} = {LNil}"
  by (auto simp add: Aczel_def Con_def)

primrec proj_power :: "('a \<times> 'a) lan \<Rightarrow> nat \<Rightarrow> ('a \<times> 'a) lan" where
  "proj_power x 0 = {LNil}"
| "proj_power x (Suc n) = \<pi> (x \<cdot> proj_power x n)"

definition proj_powers :: "('a \<times> 'a) lan \<Rightarrow> ('a \<times> 'a) lan set" where
  "proj_powers x  = {y. (\<exists>i. y = proj_power x i)}"

lemma power_to_proj: "\<pi> (power x i) = proj_power x i"
  apply (induct i)
  apply simp_all
  by (metis Aczel_idem Aczel_l_prod)

lemma proj_power_proj: "proj_power x i = proj_power (\<pi> x) i"
  apply (induct i)
  apply simp_all
  by (metis Aczel_l_prod Language.power.simps(2) power_to_proj proj_power.simps(2))

lemma powers_to_proj: "\<pi> ` powers x = proj_powers x"
  apply (auto simp add: proj_powers_def powers_def image_def)
  apply (metis power_to_proj)
  by (metis power_to_proj)

lemma proj_powers_proj: "proj_powers x = proj_powers (\<pi> x)"
  apply (auto simp add: proj_powers_def)
  apply (metis proj_power_proj)
  by (metis proj_power_proj)

lemma "\<Union>{\<pi> X |X. X \<in> powers (x \<inter> FIN)} = \<Union>{X. X \<in> \<pi> ` powers (x \<inter> FIN)}"
  by (auto simp add: image_def)

lemma Aczel_fin_star_lem: "\<Union>{\<pi> X |X. X \<in> powers (x \<inter> FIN)} = \<Union>{\<pi> X |X. X \<in> powers (\<pi> (x \<inter> FIN))}"
proof -
  have "\<Union>{\<pi> X |X. X \<in> powers (x \<inter> FIN)} = \<Union>{X. X \<in> \<pi> ` powers (x \<inter> FIN)}"
    by (auto simp add: image_def)
  also have "... = \<Union>{X. X \<in> proj_powers (x \<inter> FIN)}"
    by (metis powers_to_proj)
  also have "... = \<Union>{X. X \<in> proj_powers (\<pi> (x \<inter> FIN))}"
    by (metis proj_powers_proj)
  also have "... =  \<Union>{X. X \<in> \<pi> ` powers (\<pi> (x \<inter> FIN))}"
    by (metis powers_to_proj)
  also have "... = \<Union>{\<pi> X |X. X \<in> powers (\<pi> (x \<inter> FIN))}"
    by (auto simp add: image_def)
  finally show ?thesis .
qed

lemma Aczel_fin_star: "\<pi> ((x \<inter> FIN)\<^sup>\<star>) \<le> \<pi> ((\<pi> (x \<inter> FIN))\<^sup>\<star>)"
  apply (subst star_power_fin)
  apply simp
  apply (subst star_power_fin)
  apply (metis Aczel_coextensive inf.bounded_iff)
  apply (subst Aczel_continuous)+
  by (metis Aczel_fin_star_lem subset_refl)

lemma Aczel_star1: "\<pi> (x\<^sup>\<star>) \<le> \<pi> (\<pi> x\<^sup>\<star>)"
proof -
  have "\<pi> (x\<^sup>\<star>) = \<pi> ((x \<inter> FIN \<union> x\<cdot>{})\<^sup>\<star>)"
    by simp
  also have "... = \<pi> ((x \<inter> FIN)\<^sup>\<star>\<cdot>x\<cdot>{} \<union> (x \<inter> FIN)\<^sup>\<star>)"
    by (simp only: seq.inf_part_star)
  also have "... = \<pi> ((x \<inter> FIN)\<^sup>\<star> \<cdot> (x\<cdot>{} \<union> {LNil}))"
    by (metis seq.distrib_left seq.mult.right_neutral seq.mult_assoc)
  also have "... = \<pi> (\<pi> ((x \<inter> FIN)\<^sup>\<star>) \<cdot> \<pi> (x\<cdot>{} \<union> {LNil}))"
    by (metis Aczel_l_prod)
  also have "... \<le> \<pi> (\<pi> ((\<pi> (x \<inter> FIN))\<^sup>\<star>) \<cdot> \<pi> (x\<cdot>{} \<union> {LNil}))"
    by (metis (hide_lams, no_types) Aczel_fin_star Aczel_iso seq.mult_isor)
  also have "... = \<pi> (\<pi> (\<pi> (x \<inter> FIN)\<^sup>\<star>) \<cdot> (\<pi> x \<cdot> {} \<union> {LNil}))"
    by (simp only: Aczel_union Aczel_inf Aczel_one)
  also have "... = \<pi> (\<pi> (\<pi> (x \<inter> FIN)\<^sup>\<star>) \<cdot> \<pi> x \<cdot> {} \<union> \<pi> (\<pi> (x \<inter> FIN)\<^sup>\<star>))"
    by (metis seq.distrib_left seq.mult.right_neutral seq.mult_assoc)
  also have "... = \<pi> (\<pi> (x \<inter> FIN)\<^sup>\<star> \<cdot> \<pi> x \<cdot> {} \<union> \<pi> (x \<inter> FIN)\<^sup>\<star>)"
    by (metis Aczel_idem Aczel_l_prod Aczel_union)
  also have "... = \<pi> ((\<pi> (x \<inter> FIN) \<union> \<pi> x \<cdot> {})\<^sup>\<star>)"
    by (simp only: seq.inf_part_star)
  also have "... = \<pi> ((\<pi> (x \<inter> FIN \<union> x\<cdot>{}))\<^sup>\<star>)"
    by (simp only: Aczel_union Aczel_inf Aczel_idem)
  also have "... = \<pi> (\<pi> x\<^sup>\<star>)"
    by simp
  finally show ?thesis .
qed

lemma Aczel_star [simp]: "\<pi> (\<pi> x\<^sup>\<star>) = \<pi> (x\<^sup>\<star>)"
  by (metis Aczel_def Aczel_iso Aczel_star1 par.add_ub2 seq.star_iso subset_antisym sup_inf_absorb)

end


theory Composition_Core imports "../Mergeable/Mergeable" "../Mergeable/Mergeable_Facts"
begin

(* TODO: do we actually need to import lifter?*)

(* Here we begin to develop some primitives for language composition,
 * based on the partial-ordering-based
 * framework developed in Mergeable. We take multiple semantics ('a \<Rightarrow> 'b \<Rightarrow> 'b) and calculate
 * a new one of the same type. The idea is "run all of them, and then take the bsup of the result".
 *
 * Lang_Comp completes the appropriate definitions for composition, in a very general setting.
 * See Lang_Comp_Simple for a less-powerful but possibly easier-to-understand alternative.
 *
 * Since we know that bsup calculates the true supremum
 * of any inputs which have a supremum, we just need to show that the necessary suprema exist.
 * We then can meaningfully talk about a semantics that represents the merger of several
 * others, with the information ordering naturally resolving any "conflicts" between
 * these semantics' behaviors.
 *)

(* TODO: we seem to have a few different primitives that capture different notions of
 * compatability of semantics: sups_pres, sup_l, orthogonal liftings
 * it would be nice to have a clear statement somewhere of the relationship between
 * all these.
 *)

(* We will be presented with a list of language semantics, but will prefer to work
 * with sets whenever possible. *)
type_synonym ('a, 'b) langcomps =
  "('a \<Rightarrow> 'b \<Rightarrow> 'b) list"

(* Pcomps ("Parallel CompositionS") will calculate the merged semantics using bsup -
 * but is only guaranteed to be well-behaved under certain conditions (corresponding
 * to the existence of some necessary suprema).
 *
 * The idea is that in such cases, the ordering of composition doesn't matter
 * (since our composition operator bsup will coincide with sup; thus will be commutative
 * and associative) so we can just fold along the list in the natural order. *)
fun pcomps :: "('a, 'b :: Mergeable) langcomps \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'b)" where
"pcomps [] a b = b"
| "pcomps [lh] a b = lh a b"
| "pcomps (lh#lt) a b =
   [^ lh a b, pcomps lt a b ^]"

(* Map a set of functions over inputs drawn from another set *)
definition scross :: "('a \<Rightarrow> 'b) set \<Rightarrow> 'a set \<Rightarrow> 'b set" where
"scross Fs Xs =
  { x . \<exists> f y . f \<in> Fs \<and> y \<in> Xs \<and> x = f y }"

lemma scross_inI :
  assumes Hf : "f \<in> Fs"
  assumes Hx : "x \<in> Xs"
  assumes Heq : "res = f x"
  shows "res \<in> scross Fs Xs" using assms
  unfolding scross_def
  by blast

lemma scross_inD  :
  assumes "res \<in> scross Fs Xs"
  shows "\<exists> f y . f \<in> Fs \<and> y \<in> Xs \<and> res = f y" using assms
  unfolding scross_def
  by blast

lemma pcomps_cons_same :
  shows "pcomps (x#x#t) = pcomps (x#t)"
proof(induction t arbitrary: x)
  case Nil
  then show ?case
    by(auto simp add: bsup_idem)
next
  case (Cons a1 t1)
  then show ?case unfolding pcomps.simps bsup_base_eq
    by auto
qed

end


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

section\<open>CIDR Split Motivation (Example for IPv4)\<close>
  text\<open>When talking about ranges of IP addresses, we can make the ranges explicit by listing their elements.\<close>
context
begin
  private lemma "map (of_nat \<circ> nat) [1 .. 4] = ([1, 2, 3, 4]:: 32 word list)" by eval
  private definition ipv4addr_upto :: "32 word \<Rightarrow> 32 word \<Rightarrow> 32 word list" where
    "ipv4addr_upto i j \<equiv> map (of_nat \<circ> nat) [int (unat i) .. int (unat j)]"
  private lemma ipv4addr_upto: "set (ipv4addr_upto i j) = {i .. j}"
    proof -
    have helpX:"\<And>f (i::nat) (j::nat). (f \<circ> nat) ` {int i..int j} = f ` {i .. j}"
      apply(intro set_eqI)
      apply(safe)
       apply(force)
      by (metis Set_Interval.transfer_nat_int_set_functions(2) image_comp image_eqI)
    {   fix xa :: int
        assume a1: "int (unat i) \<le> xa \<and> xa \<le> int (unat j)"
        then have f2: "int (nat xa) = xa"
          by force
        then have "unat (of_int xa::32 word) = nat xa"
          using a1 by (metis (full_types) le_unat_uoi nat_int nat_mono of_int_of_nat_eq)
        then have "i \<le> of_int xa" and "of_int xa \<le> j"
          using f2 a1 by (metis (no_types) uint_nat word_le_def)+
    } note hlp=this
    show ?thesis
      unfolding ipv4addr_upto_def
      apply(intro set_eqI)
      apply(simp)
      apply(safe)
        apply(simp_all)
        using hlp apply blast
       using hlp apply blast
      apply(simp add: helpX)
      by (metis atLeastAtMost_iff image_eqI word_le_nat_alt word_unat.Rep_inverse)
    qed

  text\<open>The function @{const ipv4addr_upto} gives back a list of all the ips in the list.
        This list can be pretty huge! In the following, we will use CIDR notation (e.g. 192.168.0.0/24)
        to describe the list more compactly.\<close>
end

section\<open>CIDR Split\<close>

context
begin

private lemma find_SomeD: "find f x = Some y \<Longrightarrow> f y \<and> y \<in> set x"
  by(induction x; simp split: if_splits)

(*pfxes needs a dummy parameter. The first parameter is a dummy that we have the 'a::len0 type and
  can refer to its length.*)
private definition pfxes :: "'a::len0 itself \<Rightarrow> nat list" where
  "pfxes _ = map nat [0..int(len_of TYPE ('a))]"
private lemma "pfxes TYPE(32) = map nat [0 .. 32]" by eval

private definition "largest_contained_prefix (a::('a :: len) word) r = (
  let cs = (map (\<lambda>s. PrefixMatch a s) (pfxes TYPE('a)));
      (* anything that is a subset should also be a valid prefix. but try proving that.*)
      cfs = find (\<lambda>s. valid_prefix s \<and> wordinterval_subset (prefix_to_wordinterval s) r) cs in
  cfs)
"
(* The joke is that it is always Some, given that a \<in> r. *)

text\<open>Split off one prefix:\<close>
private definition wordinterval_CIDR_split1
  :: "'a::len wordinterval \<Rightarrow> 'a prefix_match option \<times> 'a wordinterval" where
  "wordinterval_CIDR_split1 r \<equiv> (
   let ma = wordinterval_lowest_element r in
   case ma of
      None \<Rightarrow> (None, r) |
      Some a \<Rightarrow> (case largest_contained_prefix a r of
        None \<Rightarrow> (None, r) |
        Some m \<Rightarrow> (Some m, wordinterval_setminus r (prefix_to_wordinterval m))))"

private lemma wordinterval_CIDR_split1_innard_helper: fixes a::"'a::len word"
  shows "wordinterval_lowest_element r = Some a \<Longrightarrow>
  largest_contained_prefix a r \<noteq> None"
proof -
  assume a: "wordinterval_lowest_element r = Some a"
  have b: "(a,len_of(TYPE('a))) \<in> set (map (Pair a) (pfxes TYPE('a)))"
    unfolding pfxes_def set_map set_upto
    using Set.image_iff atLeastAtMost_iff int_eq_iff order_refl by metis (*400ms*)
  have c: "valid_prefix (PrefixMatch a (len_of(TYPE('a))))" by(simp add: valid_prefix_def pfxm_mask_def)
  have "wordinterval_to_set (prefix_to_wordinterval (PrefixMatch a (len_of(TYPE('a))))) = {a}"
    unfolding prefix_to_wordinterval_def pfxm_mask_def by simp
  moreover have "a \<in> wordinterval_to_set r"
    using a wordinterval_lowest_element_set_eq wordinterval_lowest_none_empty
    by (metis is_lowest_element_def option.distinct(1))
  ultimately have d:
    "wordinterval_to_set (prefix_to_wordinterval (PrefixMatch a (len_of TYPE('a)))) \<subseteq> wordinterval_to_set r"
    by simp
  show ?thesis
    unfolding largest_contained_prefix_def Let_def
    using b c d by(auto simp add: find_None_iff)
qed

private lemma r_split1_not_none: fixes r:: "'a::len wordinterval"
  shows "\<not> wordinterval_empty r \<Longrightarrow> fst (wordinterval_CIDR_split1 r) \<noteq> None"
  unfolding wordinterval_CIDR_split1_def Let_def
  by(cases "wordinterval_lowest_element r")
    (auto simp add: wordinterval_lowest_none_empty
          dest: wordinterval_CIDR_split1_innard_helper)

private lemma largest_contained_prefix_subset:
  "largest_contained_prefix a r = Some p \<Longrightarrow> wordinterval_to_set (prefix_to_wordinterval p) \<subseteq> wordinterval_to_set r"
unfolding largest_contained_prefix_def Let_def
by(drule find_SomeD) simp

private lemma wordinterval_CIDR_split1_snd: "wordinterval_CIDR_split1 r = (Some s, u) \<Longrightarrow> u = wordinterval_setminus r (prefix_to_wordinterval s)"
  unfolding wordinterval_CIDR_split1_def Let_def by(clarsimp split: option.splits)

private lemma largest_contained_prefix_subset_s1D:
  "wordinterval_CIDR_split1 r = (Some s, u) \<Longrightarrow> wordinterval_to_set (prefix_to_wordinterval s) \<subseteq> wordinterval_to_set r"
by(intro largest_contained_prefix_subset[where a = "the (wordinterval_lowest_element r)"])
  (simp add: wordinterval_CIDR_split1_def split: option.splits)

private theorem wordinterval_CIDR_split1_preserve: fixes r:: "'a::len wordinterval"
  shows "wordinterval_CIDR_split1 r = (Some s, u) \<Longrightarrow> wordinterval_eq (wordinterval_union (prefix_to_wordinterval s) u) r"
proof(unfold wordinterval_eq_set_eq)
  assume as: "wordinterval_CIDR_split1 r = (Some s, u)"
  have ud: "u = wordinterval_setminus r (prefix_to_wordinterval s)"
    using as[THEN wordinterval_CIDR_split1_snd] .
  with largest_contained_prefix_subset_s1D[OF as]
  show "wordinterval_to_set (wordinterval_union (prefix_to_wordinterval s) u) = wordinterval_to_set r"
    unfolding ud by auto
qed

private lemma wordinterval_CIDR_split1_some_r_ne:
  "wordinterval_CIDR_split1 r = (Some s, u) \<Longrightarrow> \<not> wordinterval_empty r"
proof(rule ccontr, goal_cases)
  case 1
  have "wordinterval_lowest_element r = None" unfolding wordinterval_lowest_none_empty using 1(2) unfolding not_not .
  then have "wordinterval_CIDR_split1 r = (None, r)" unfolding wordinterval_CIDR_split1_def Let_def by simp
  then show False using 1(1) by simp
qed

private lemma wordinterval_CIDR_split1_distinct: fixes r:: "'a::len wordinterval"
  shows "wordinterval_CIDR_split1 r = (Some s, u) \<Longrightarrow>
           wordinterval_empty (wordinterval_intersection (prefix_to_wordinterval s) u)"
proof(goal_cases)
  case 1
  have nn: "wordinterval_lowest_element r \<noteq> None"
    using wordinterval_CIDR_split1_some_r_ne 1 wordinterval_lowest_none_empty by metis
  from 1 have "u = wordinterval_setminus r (prefix_to_wordinterval s)"
    by(elim wordinterval_CIDR_split1_snd)
  then show ?thesis by simp
qed

private lemma wordinterval_CIDR_split1_distinct2: fixes r:: "'a::len wordinterval"
  shows "wordinterval_CIDR_split1 r = (Some s, u) \<Longrightarrow>
          wordinterval_empty (wordinterval_intersection (prefix_to_wordinterval s) u)"
by(rule wordinterval_CIDR_split1_distinct[where r = r]) simp

function wordinterval_CIDR_split_prefixmatch
  :: "'a::len wordinterval \<Rightarrow> 'a prefix_match list" where
  "wordinterval_CIDR_split_prefixmatch rs = (
      if
        \<not> wordinterval_empty rs
      then case wordinterval_CIDR_split1 rs
                      of (Some s, u) \<Rightarrow> s # wordinterval_CIDR_split_prefixmatch u
                      |   _ \<Rightarrow> []
      else
        []
      )"
  by pat_completeness simp

termination wordinterval_CIDR_split_prefixmatch
proof(relation "measure (card \<circ> wordinterval_to_set)", rule wf_measure, unfold in_measure comp_def, goal_cases)
  note vernichter = wordinterval_empty_set_eq wordinterval_intersection_set_eq wordinterval_union_set_eq wordinterval_eq_set_eq
  case (1 rs x y x2)
  note some = 1(2)[unfolded 1(3), symmetric]
  from prefix_never_empty have "wordinterval_to_set (prefix_to_wordinterval x2) \<noteq> {}" unfolding vernichter .
  thus ?case
    unfolding wordinterval_CIDR_split1_preserve[OF some, unfolded vernichter, symmetric]
    unfolding card_Un_disjoint[OF finite finite wordinterval_CIDR_split1_distinct[OF some, unfolded vernichter]]
    by auto
qed

private lemma unfold_rsplit_case:
  assumes su: "(Some s, u) = wordinterval_CIDR_split1 rs"
  shows "(case wordinterval_CIDR_split1 rs of (None, u) \<Rightarrow> []
                                            | (Some s, u) \<Rightarrow> s # wordinterval_CIDR_split_prefixmatch u) = s # wordinterval_CIDR_split_prefixmatch u"
using su by (metis option.simps(5) split_conv)

lemma "wordinterval_CIDR_split_prefixmatch
          (RangeUnion (WordInterval (0x40000000) 0x5FEFBBCC) (WordInterval 0x5FEEBB1C 0x7FFFFFFF))
       = [PrefixMatch (0x40000000::32 word) 2]" by eval
lemma "length (wordinterval_CIDR_split_prefixmatch (WordInterval 0 (0xFFFFFFFE::32 word))) = 32" by eval

declare wordinterval_CIDR_split_prefixmatch.simps[simp del]

theorem wordinterval_CIDR_split_prefixmatch:
  "wordinterval_to_set r = (\<Union>x\<in>set (wordinterval_CIDR_split_prefixmatch r). prefix_to_wordset x)"
proof(induction r rule: wordinterval_CIDR_split_prefixmatch.induct)
  case (1 rs)
  show ?case proof(cases "wordinterval_empty rs")
    case True
    thus ?thesis by(simp add: wordinterval_CIDR_split_prefixmatch.simps)
  next
    case False
    obtain x y where s1: "wordinterval_CIDR_split1 rs = (Some x, y)"
      using r_split1_not_none[OF False] by(auto simp add: fst_def split: prod.splits)
    have mIH: "wordinterval_to_set y = (\<Union>x\<in>set (wordinterval_CIDR_split_prefixmatch y). prefix_to_wordset x)"
      using 1[OF False s1[symmetric] refl] .
    have *: "wordinterval_to_set rs = prefix_to_wordset x \<union> (\<Union>x\<in>set (wordinterval_CIDR_split_prefixmatch y). prefix_to_wordset x)"
      unfolding mIH[symmetric]
    proof -
      have ud: "y = wordinterval_setminus rs (prefix_to_wordinterval x)"
        using wordinterval_CIDR_split1_snd[OF s1] .
      have ss: "prefix_to_wordset x \<subseteq> wordinterval_to_set rs"
        using largest_contained_prefix_subset_s1D[OF s1] by simp
      show "wordinterval_to_set rs = prefix_to_wordset x \<union> wordinterval_to_set y"
        unfolding ud using ss by simp blast
    qed
    show ?thesis
      apply(subst wordinterval_CIDR_split_prefixmatch.simps)
      apply(unfold if_P[OF False] s1 prod.simps option.simps *) (* WOOOOO simplifier bug (* try making this a simp add: *) *)
      apply(simp)
    done
  qed
qed

lemma wordinterval_CIDR_split_prefixmatch_all_valid_Ball: fixes r:: "'a::len wordinterval"
  shows "\<forall>e\<in>set (wordinterval_CIDR_split_prefixmatch r). valid_prefix e \<and> pfxm_length e \<le> len_of TYPE('a)"
(* The induction is somewhat verbose, so it is less annoying to write the two down at once *)
proof(induction r rule: wordinterval_CIDR_split_prefixmatch.induct)
  case 1
  case (1 rs)
  show ?case proof(cases "wordinterval_empty rs")
    case False
    obtain x y where s1: "wordinterval_CIDR_split1 rs = (Some x, y)"
      using r_split1_not_none[OF False] by(auto simp add: fst_def split: prod.splits)
    hence i1: "valid_prefix x"
      unfolding wordinterval_CIDR_split1_def Let_def largest_contained_prefix_def
      by(auto dest: find_SomeD split: option.splits)
    have i2: "pfxm_length x \<le> len_of TYPE('a)"
      using s1 unfolding wordinterval_CIDR_split1_def Let_def largest_contained_prefix_def pfxes_def
      by(force split: option.splits dest: find_SomeD simp: nat_le_iff)
    have mIH: "\<forall>a\<in>set (wordinterval_CIDR_split_prefixmatch y). valid_prefix a \<and> pfxm_length a \<le> len_of TYPE('a)"
      using 1[OF False s1[symmetric] refl] .
    with i1 i2 show ?thesis
      apply(subst wordinterval_CIDR_split_prefixmatch.simps)
      apply(unfold if_P[OF False] s1 prod.simps option.simps)
      apply(simp)
    done
  qed (simp add: wordinterval_CIDR_split_prefixmatch.simps)
qed

private lemma wordinterval_CIDR_split_prefixmatch_all_valid_less_Ball_hlp:
	"x \<in> set [s\<leftarrow>map (PrefixMatch x2) (pfxes TYPE('a::len0)) . valid_prefix s \<and> wordinterval_to_set (prefix_to_wordinterval s) \<subseteq> wordinterval_to_set rs] \<Longrightarrow> pfxm_length x \<le> len_of TYPE('a)"
by(clarsimp simp: pfxes_def) presburger

text\<open>Since @{const wordinterval_CIDR_split_prefixmatch} only returns valid prefixes, we can safely convert it to CIDR lists\<close>
(* actually, just valid_prefix doesn't mean that the prefix length is sane. Fortunately, wordinterval_CIDR_split_prefixmatch_all_valid_Ball does entail that *)
lemma "valid_prefix (PrefixMatch (0::16 word) 20)" by(simp add: valid_prefix_def)

lemma wordinterval_CIDR_split_disjunct: "a \<in> set (wordinterval_CIDR_split_prefixmatch i) \<Longrightarrow>
  b \<in> set (wordinterval_CIDR_split_prefixmatch i) \<Longrightarrow> a \<noteq> b \<Longrightarrow>
  prefix_to_wordset a \<inter> prefix_to_wordset b = {}"
proof(induction i rule: wordinterval_CIDR_split_prefixmatch.induct)
  case (1 rs)
  note IH = 1(1)
  have prema: "a \<in> set (wordinterval_CIDR_split_prefixmatch rs)" (is "a \<in> ?os") using 1 by simp
  have premb: "b \<in> ?os" using 1 by simp
  show ?case proof(cases "wordinterval_empty rs")
    case False
    obtain x y where s1: "wordinterval_CIDR_split1 rs = (Some x, y)"
      using r_split1_not_none[OF False] by(auto simp add: fst_def split: prod.splits)
    have mi: "k \<in> set (wordinterval_CIDR_split_prefixmatch y)" (is "k \<in> ?rs")
      if p: "k \<noteq> x" "k \<in> ?os" for k using p s1
      by(subst (asm) wordinterval_CIDR_split_prefixmatch.simps) (simp only: if_P[OF False] split: prod.splits option.splits; simp)
    have a: "k \<in> ?rs \<Longrightarrow> prefix_to_wordset k \<subseteq> wordinterval_to_set y" for k
      (* this is actually a quite general statement, might make a lemma out of it *)
      unfolding wordinterval_CIDR_split_prefixmatch by blast
    have b: "prefix_to_wordset x \<inter> wordinterval_to_set y = {}"
      using wordinterval_CIDR_split1_snd[OF s1] by simp
    show ?thesis
    proof(cases "a = x"; cases "b = x")
      assume as: "a = x" "b \<noteq> x"
      with a[OF mi[OF as(2) premb]] b
      show ?thesis by blast
    next
      assume as: "a \<noteq> x" "b = x"
      with a[OF mi[OF as(1) prema]] b
      show ?thesis by blast
    next
      assume as: "a \<noteq> x" "b \<noteq> x" (* Nothing to do case *)
      have i: "a \<in> ?rs" "b \<in> ?rs"
        using as mi prema premb by blast+
      show "prefix_to_wordset a \<inter> prefix_to_wordset b = {}"
        by(rule IH[OF False s1[symmetric] refl i]) (fact 1)
    next
      assume as: "a = x" "b = x" (* impossible case *)
      with 1 have False by simp
      thus ?thesis ..
    qed
  next
    case True
    hence "wordinterval_CIDR_split_prefixmatch rs = []" by(simp add: wordinterval_CIDR_split_prefixmatch.simps)
    thus ?thesis using prema by simp
  qed
qed

lemma wordinterval_CIDR_split_distinct: "distinct (wordinterval_CIDR_split_prefixmatch i)"
(* wish this was a corollary *)
proof(induction i rule: wordinterval_CIDR_split_prefixmatch.induct)
  case (1 rs)
  show ?case proof(cases "wordinterval_empty rs")
    case False
    obtain x y where s1: "wordinterval_CIDR_split1 rs = (Some x, y)"
      using r_split1_not_none[OF False] by(auto simp add: fst_def split: prod.splits)
    have mIH: "distinct (wordinterval_CIDR_split_prefixmatch y)"
      using 1[OF False s1[symmetric] refl] .
    have "prefix_to_wordset x \<inter> wordinterval_to_set y = {}"
      using wordinterval_CIDR_split1_snd[OF s1] by simp
    hence i1: "x \<notin> set (wordinterval_CIDR_split_prefixmatch y)"
      unfolding wordinterval_CIDR_split_prefixmatch using prefix_never_empty[of x, simplified] by blast
    show ?thesis
      using s1
      by(subst wordinterval_CIDR_split_prefixmatch.simps)
        (simp add: if_P[OF False] mIH i1 split: option.splits prod.splits)
  qed (simp add: wordinterval_CIDR_split_prefixmatch.simps)
qed

lemma wordinterval_CIDR_split_existential:
	"x \<in> wordinterval_to_set w \<Longrightarrow> \<exists>s. s \<in> set (wordinterval_CIDR_split_prefixmatch w) \<and> x \<in> prefix_to_wordset s"
using wordinterval_CIDR_split_prefixmatch[symmetric] by fastforce

subsection\<open>Versions for @{const ipset_from_cidr}\<close>

definition cidr_split :: "'i::len wordinterval \<Rightarrow> ('i word \<times> nat) list" where
  "cidr_split rs \<equiv> map prefix_match_to_CIDR (wordinterval_CIDR_split_prefixmatch rs)"

corollary cidr_split_prefix:
  fixes r :: "'i::len wordinterval"
  shows "(\<Union>x\<in>set (cidr_split r). uncurry ipset_from_cidr x) = wordinterval_to_set r"
    unfolding wordinterval_CIDR_split_prefixmatch[symmetric] cidr_split_def
    apply(simp add: prefix_match_to_CIDR_def2 wordinterval_CIDR_split_prefixmatch)
    using prefix_to_wordset_ipset_from_cidr wordinterval_CIDR_split_prefixmatch_all_valid_Ball by blast

corollary cidr_split_prefix_single:
  fixes start :: "'i::len word"
  shows "(\<Union>x\<in>set (cidr_split (iprange_interval (start, end))). uncurry ipset_from_cidr x) = {start..end}"
  unfolding wordinterval_to_set.simps[symmetric]
  using cidr_split_prefix iprange_interval.simps by metis

private lemma interval_in_splitD: "xa \<in> foo \<Longrightarrow> prefix_to_wordset xa \<subseteq> \<Union>(prefix_to_wordset ` foo)" by auto

end

end