(*  Title:      HOL/Library/Sublist.thy
    Author:     Tobias Nipkow and Markus Wenzel, TU Muenchen
    Author:     Christian Sternagel, JAIST
*)

section {* List prefixes, suffixes, and homeomorphic embedding *}

theory Sublist
imports Main
begin

subsection {* Prefix order on lists *}

definition prefixeq :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  where "prefixeq xs ys \<longleftrightarrow> (\<exists>zs. ys = xs @ zs)"

definition prefix :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  where "prefix xs ys \<longleftrightarrow> prefixeq xs ys \<and> xs \<noteq> ys"

interpretation prefix_order: order prefixeq prefix
  by default (auto simp: prefixeq_def prefix_def)

interpretation prefix_bot: order_bot Nil prefixeq prefix
  by default (simp add: prefixeq_def)

lemma prefixeqI [intro?]: "ys = xs @ zs \<Longrightarrow> prefixeq xs ys"
  unfolding prefixeq_def by blast

lemma prefixeqE [elim?]:
  assumes "prefixeq xs ys"
  obtains zs where "ys = xs @ zs"
  using assms unfolding prefixeq_def by blast

lemma prefixI' [intro?]: "ys = xs @ z # zs \<Longrightarrow> prefix xs ys"
  unfolding prefix_def prefixeq_def by blast

lemma prefixE' [elim?]:
  assumes "prefix xs ys"
  obtains z zs where "ys = xs @ z # zs"
proof -
  from `prefix xs ys` obtain us where "ys = xs @ us" and "xs \<noteq> ys"
    unfolding prefix_def prefixeq_def by blast
  with that show ?thesis by (auto simp add: neq_Nil_conv)
qed

lemma prefixI [intro?]: "prefixeq xs ys \<Longrightarrow> xs \<noteq> ys \<Longrightarrow> prefix xs ys"
  unfolding prefix_def by blast

lemma prefixE [elim?]:
  fixes xs ys :: "'a list"
  assumes "prefix xs ys"
  obtains "prefixeq xs ys" and "xs \<noteq> ys"
  using assms unfolding prefix_def by blast

subsection {* Basic properties of prefixes *}

theorem Nil_prefixeq [iff]: "prefixeq [] xs"
  by (simp add: prefixeq_def)

theorem prefixeq_Nil [simp]: "(prefixeq xs []) = (xs = [])"
  by (induct xs) (simp_all add: prefixeq_def)

lemma prefixeq_snoc [simp]: "prefixeq xs (ys @ [y]) \<longleftrightarrow> xs = ys @ [y] \<or> prefixeq xs ys"
proof
  assume "prefixeq xs (ys @ [y])"
  then obtain zs where zs: "ys @ [y] = xs @ zs" ..
  show "xs = ys @ [y] \<or> prefixeq xs ys"
    by (metis append_Nil2 butlast_append butlast_snoc prefixeqI zs)
next
  assume "xs = ys @ [y] \<or> prefixeq xs ys"
  then show "prefixeq xs (ys @ [y])"
    by (metis prefix_order.eq_iff prefix_order.order_trans prefixeqI)
qed

lemma Cons_prefixeq_Cons [simp]: "prefixeq (x # xs) (y # ys) = (x = y \<and> prefixeq xs ys)"
  by (auto simp add: prefixeq_def)

lemma prefixeq_code [code]:
  "prefixeq [] xs \<longleftrightarrow> True"
  "prefixeq (x # xs) [] \<longleftrightarrow> False"
  "prefixeq (x # xs) (y # ys) \<longleftrightarrow> x = y \<and> prefixeq xs ys"
  by simp_all

lemma same_prefixeq_prefixeq [simp]: "prefixeq (xs @ ys) (xs @ zs) = prefixeq ys zs"
  by (induct xs) simp_all

lemma same_prefixeq_nil [iff]: "prefixeq (xs @ ys) xs = (ys = [])"
  by (metis append_Nil2 append_self_conv prefix_order.eq_iff prefixeqI)

lemma prefixeq_prefixeq [simp]: "prefixeq xs ys \<Longrightarrow> prefixeq xs (ys @ zs)"
  by (metis prefix_order.le_less_trans prefixeqI prefixE prefixI)

lemma append_prefixeqD: "prefixeq (xs @ ys) zs \<Longrightarrow> prefixeq xs zs"
  by (auto simp add: prefixeq_def)

theorem prefixeq_Cons: "prefixeq xs (y # ys) = (xs = [] \<or> (\<exists>zs. xs = y # zs \<and> prefixeq zs ys))"
  by (cases xs) (auto simp add: prefixeq_def)

theorem prefixeq_append:
  "prefixeq xs (ys @ zs) = (prefixeq xs ys \<or> (\<exists>us. xs = ys @ us \<and> prefixeq us zs))"
  apply (induct zs rule: rev_induct)
   apply force
  apply (simp del: append_assoc add: append_assoc [symmetric])
  apply (metis append_eq_appendI)
  done

lemma append_one_prefixeq:
  "prefixeq xs ys \<Longrightarrow> length xs < length ys \<Longrightarrow> prefixeq (xs @ [ys ! length xs]) ys"
  proof (unfold prefixeq_def)
    assume a1: "\<exists>zs. ys = xs @ zs"
    then obtain sk :: "'a list" where sk: "ys = xs @ sk" by fastforce
    assume a2: "length xs < length ys"
    have f1: "\<And>v. ([]\<Colon>'a list) @ v = v" using append_Nil2 by simp
    have "[] \<noteq> sk" using a1 a2 sk less_not_refl by force
    hence "\<exists>v. xs @ hd sk # v = ys" using sk by (metis hd_Cons_tl)
    thus "\<exists>zs. ys = (xs @ [ys ! length xs]) @ zs" using f1 by fastforce
  qed

theorem prefixeq_length_le: "prefixeq xs ys \<Longrightarrow> length xs \<le> length ys"
  by (auto simp add: prefixeq_def)

lemma prefixeq_same_cases:
  "prefixeq (xs\<^sub>1::'a list) ys \<Longrightarrow> prefixeq xs\<^sub>2 ys \<Longrightarrow> prefixeq xs\<^sub>1 xs\<^sub>2 \<or> prefixeq xs\<^sub>2 xs\<^sub>1"
  unfolding prefixeq_def by (force simp: append_eq_append_conv2)

lemma set_mono_prefixeq: "prefixeq xs ys \<Longrightarrow> set xs \<subseteq> set ys"
  by (auto simp add: prefixeq_def)

lemma take_is_prefixeq: "prefixeq (take n xs) xs"
  unfolding prefixeq_def by (metis append_take_drop_id)

lemma map_prefixeqI: "prefixeq xs ys \<Longrightarrow> prefixeq (map f xs) (map f ys)"
  by (auto simp: prefixeq_def)

lemma prefixeq_length_less: "prefix xs ys \<Longrightarrow> length xs < length ys"
  by (auto simp: prefix_def prefixeq_def)

lemma prefix_simps [simp, code]:
  "prefix xs [] \<longleftrightarrow> False"
  "prefix [] (x # xs) \<longleftrightarrow> True"
  "prefix (x # xs) (y # ys) \<longleftrightarrow> x = y \<and> prefix xs ys"
  by (simp_all add: prefix_def cong: conj_cong)

lemma take_prefix: "prefix xs ys \<Longrightarrow> prefix (take n xs) ys"
  apply (induct n arbitrary: xs ys)
   apply (case_tac ys, simp_all)[1]
  apply (metis prefix_order.less_trans prefixI take_is_prefixeq)
  done

lemma not_prefixeq_cases:
  assumes pfx: "\<not> prefixeq ps ls"
  obtains
    (c1) "ps \<noteq> []" and "ls = []"
  | (c2) a as x xs where "ps = a#as" and "ls = x#xs" and "x = a" and "\<not> prefixeq as xs"
  | (c3) a as x xs where "ps = a#as" and "ls = x#xs" and "x \<noteq> a"
proof (cases ps)
  case Nil
  then show ?thesis using pfx by simp
next
  case (Cons a as)
  note c = `ps = a#as`
  show ?thesis
  proof (cases ls)
    case Nil then show ?thesis by (metis append_Nil2 pfx c1 same_prefixeq_nil)
  next
    case (Cons x xs)
    show ?thesis
    proof (cases "x = a")
      case True
      have "\<not> prefixeq as xs" using pfx c Cons True by simp
      with c Cons True show ?thesis by (rule c2)
    next
      case False
      with c Cons show ?thesis by (rule c3)
    qed
  qed
qed

lemma not_prefixeq_induct [consumes 1, case_names Nil Neq Eq]:
  assumes np: "\<not> prefixeq ps ls"
    and base: "\<And>x xs. P (x#xs) []"
    and r1: "\<And>x xs y ys. x \<noteq> y \<Longrightarrow> P (x#xs) (y#ys)"
    and r2: "\<And>x xs y ys. \<lbrakk> x = y; \<not> prefixeq xs ys; P xs ys \<rbrakk> \<Longrightarrow> P (x#xs) (y#ys)"
  shows "P ps ls" using np
proof (induct ls arbitrary: ps)
  case Nil then show ?case
    by (auto simp: neq_Nil_conv elim!: not_prefixeq_cases intro!: base)
next
  case (Cons y ys)
  then have npfx: "\<not> prefixeq ps (y # ys)" by simp
  then obtain x xs where pv: "ps = x # xs"
    by (rule not_prefixeq_cases) auto
  show ?case by (metis Cons.hyps Cons_prefixeq_Cons npfx pv r1 r2)
qed

subsection {* Parallel lists *}

definition parallel :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"  (infixl "\<parallel>" 50)
  where "(xs \<parallel> ys) = (\<not> prefixeq xs ys \<and> \<not> prefixeq ys xs)"

lemma parallelI [intro]: "\<not> prefixeq xs ys \<Longrightarrow> \<not> prefixeq ys xs \<Longrightarrow> xs \<parallel> ys"
  unfolding parallel_def by blast

lemma parallelE [elim]:
  assumes "xs \<parallel> ys"
  obtains "\<not> prefixeq xs ys \<and> \<not> prefixeq ys xs"
  using assms unfolding parallel_def by blast

theorem prefixeq_cases:
  obtains "prefixeq xs ys" | "prefix ys xs" | "xs \<parallel> ys"
  unfolding parallel_def prefix_def by blast

theorem parallel_decomp:
  "xs \<parallel> ys \<Longrightarrow> \<exists>as b bs c cs. b \<noteq> c \<and> xs = as @ b # bs \<and> ys = as @ c # cs"
proof (induct xs rule: rev_induct)
  case Nil
  then have False by auto
  then show ?case ..
next
  case (snoc x xs)
  show ?case
  proof (rule prefixeq_cases)
    assume le: "prefixeq xs ys"
    then obtain ys' where ys: "ys = xs @ ys'" ..
    show ?thesis
    proof (cases ys')
      assume "ys' = []"
      then show ?thesis by (metis append_Nil2 parallelE prefixeqI snoc.prems ys)
    next
      fix c cs assume ys': "ys' = c # cs"
      have "x \<noteq> c" using snoc.prems ys ys' by fastforce
      thus "\<exists>as b bs c cs. b \<noteq> c \<and> xs @ [x] = as @ b # bs \<and> ys = as @ c # cs"
        using ys ys' by blast
    qed
  next
    assume "prefix ys xs"
    then have "prefixeq ys (xs @ [x])" by (simp add: prefix_def)
    with snoc have False by blast
    then show ?thesis ..
  next
    assume "xs \<parallel> ys"
    with snoc obtain as b bs c cs where neq: "(b::'a) \<noteq> c"
      and xs: "xs = as @ b # bs" and ys: "ys = as @ c # cs"
      by blast
    from xs have "xs @ [x] = as @ b # (bs @ [x])" by simp
    with neq ys show ?thesis by blast
  qed
qed

lemma parallel_append: "a \<parallel> b \<Longrightarrow> a @ c \<parallel> b @ d"
  apply (rule parallelI)
    apply (erule parallelE, erule conjE,
      induct rule: not_prefixeq_induct, simp+)+
  done

lemma parallel_appendI: "xs \<parallel> ys \<Longrightarrow> x = xs @ xs' \<Longrightarrow> y = ys @ ys' \<Longrightarrow> x \<parallel> y"
  by (simp add: parallel_append)

lemma parallel_commute: "a \<parallel> b \<longleftrightarrow> b \<parallel> a"
  unfolding parallel_def by auto

subsection {* Suffix order on lists *}

definition suffixeq :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  where "suffixeq xs ys = (\<exists>zs. ys = zs @ xs)"

definition suffix :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  where "suffix xs ys \<longleftrightarrow> (\<exists>us. ys = us @ xs \<and> us \<noteq> [])"

lemma suffix_imp_suffixeq:
  "suffix xs ys \<Longrightarrow> suffixeq xs ys"
  by (auto simp: suffixeq_def suffix_def)

lemma suffixeqI [intro?]: "ys = zs @ xs \<Longrightarrow> suffixeq xs ys"
  unfolding suffixeq_def by blast

lemma suffixeqE [elim?]:
  assumes "suffixeq xs ys"
  obtains zs where "ys = zs @ xs"
  using assms unfolding suffixeq_def by blast

lemma suffixeq_refl [iff]: "suffixeq xs xs"
  by (auto simp add: suffixeq_def)
lemma suffix_trans:
  "suffix xs ys \<Longrightarrow> suffix ys zs \<Longrightarrow> suffix xs zs"
  by (auto simp: suffix_def)
lemma suffixeq_trans: "\<lbrakk>suffixeq xs ys; suffixeq ys zs\<rbrakk> \<Longrightarrow> suffixeq xs zs"
  by (auto simp add: suffixeq_def)
lemma suffixeq_antisym: "\<lbrakk>suffixeq xs ys; suffixeq ys xs\<rbrakk> \<Longrightarrow> xs = ys"
  by (auto simp add: suffixeq_def)

lemma suffixeq_tl [simp]: "suffixeq (tl xs) xs"
  by (induct xs) (auto simp: suffixeq_def)

lemma suffix_tl [simp]: "xs \<noteq> [] \<Longrightarrow> suffix (tl xs) xs"
  by (induct xs) (auto simp: suffix_def)

lemma Nil_suffixeq [iff]: "suffixeq [] xs"
  by (simp add: suffixeq_def)
lemma suffixeq_Nil [simp]: "(suffixeq xs []) = (xs = [])"
  by (auto simp add: suffixeq_def)

lemma suffixeq_ConsI: "suffixeq xs ys \<Longrightarrow> suffixeq xs (y # ys)"
  by (auto simp add: suffixeq_def)
lemma suffixeq_ConsD: "suffixeq (x # xs) ys \<Longrightarrow> suffixeq xs ys"
  by (auto simp add: suffixeq_def)

lemma suffixeq_appendI: "suffixeq xs ys \<Longrightarrow> suffixeq xs (zs @ ys)"
  by (auto simp add: suffixeq_def)
lemma suffixeq_appendD: "suffixeq (zs @ xs) ys \<Longrightarrow> suffixeq xs ys"
  by (auto simp add: suffixeq_def)

lemma suffix_set_subset:
  "suffix xs ys \<Longrightarrow> set xs \<subseteq> set ys" by (auto simp: suffix_def)

lemma suffixeq_set_subset:
  "suffixeq xs ys \<Longrightarrow> set xs \<subseteq> set ys" by (auto simp: suffixeq_def)

lemma suffixeq_ConsD2: "suffixeq (x # xs) (y # ys) \<Longrightarrow> suffixeq xs ys"
proof -
  assume "suffixeq (x # xs) (y # ys)"
  then obtain zs where "y # ys = zs @ x # xs" ..
  then show ?thesis
    by (induct zs) (auto intro!: suffixeq_appendI suffixeq_ConsI)
qed

lemma suffixeq_to_prefixeq [code]: "suffixeq xs ys \<longleftrightarrow> prefixeq (rev xs) (rev ys)"
proof
  assume "suffixeq xs ys"
  then obtain zs where "ys = zs @ xs" ..
  then have "rev ys = rev xs @ rev zs" by simp
  then show "prefixeq (rev xs) (rev ys)" ..
next
  assume "prefixeq (rev xs) (rev ys)"
  then obtain zs where "rev ys = rev xs @ zs" ..
  then have "rev (rev ys) = rev zs @ rev (rev xs)" by simp
  then have "ys = rev zs @ xs" by simp
  then show "suffixeq xs ys" ..
qed

lemma distinct_suffixeq: "distinct ys \<Longrightarrow> suffixeq xs ys \<Longrightarrow> distinct xs"
  by (clarsimp elim!: suffixeqE)

lemma suffixeq_map: "suffixeq xs ys \<Longrightarrow> suffixeq (map f xs) (map f ys)"
  by (auto elim!: suffixeqE intro: suffixeqI)

lemma suffixeq_drop: "suffixeq (drop n as) as"
  unfolding suffixeq_def
  apply (rule exI [where x = "take n as"])
  apply simp
  done

lemma suffixeq_take: "suffixeq xs ys \<Longrightarrow> ys = take (length ys - length xs) ys @ xs"
  by (auto elim!: suffixeqE)

lemma suffixeq_suffix_reflclp_conv: "suffixeq = suffix\<^sup>=\<^sup>="
proof (intro ext iffI)
  fix xs ys :: "'a list"
  assume "suffixeq xs ys"
  show "suffix\<^sup>=\<^sup>= xs ys"
  proof
    assume "xs \<noteq> ys"
    with `suffixeq xs ys` show "suffix xs ys"
      by (auto simp: suffixeq_def suffix_def)
  qed
next
  fix xs ys :: "'a list"
  assume "suffix\<^sup>=\<^sup>= xs ys"
  then show "suffixeq xs ys"
  proof
    assume "suffix xs ys" then show "suffixeq xs ys"
      by (rule suffix_imp_suffixeq)
  next
    assume "xs = ys" then show "suffixeq xs ys"
      by (auto simp: suffixeq_def)
  qed
qed

lemma parallelD1: "x \<parallel> y \<Longrightarrow> \<not> prefixeq x y"
  by blast

lemma parallelD2: "x \<parallel> y \<Longrightarrow> \<not> prefixeq y x"
  by blast

lemma parallel_Nil1 [simp]: "\<not> x \<parallel> []"
  unfolding parallel_def by simp

lemma parallel_Nil2 [simp]: "\<not> [] \<parallel> x"
  unfolding parallel_def by simp

lemma Cons_parallelI1: "a \<noteq> b \<Longrightarrow> a # as \<parallel> b # bs"
  by auto

lemma Cons_parallelI2: "\<lbrakk> a = b; as \<parallel> bs \<rbrakk> \<Longrightarrow> a # as \<parallel> b # bs"
  by (metis Cons_prefixeq_Cons parallelE parallelI)

lemma not_equal_is_parallel:
  assumes neq: "xs \<noteq> ys"
    and len: "length xs = length ys"
  shows "xs \<parallel> ys"
  using len neq
proof (induct rule: list_induct2)
  case Nil
  then show ?case by simp
next
  case (Cons a as b bs)
  have ih: "as \<noteq> bs \<Longrightarrow> as \<parallel> bs" by fact
  show ?case
  proof (cases "a = b")
    case True
    then have "as \<noteq> bs" using Cons by simp
    then show ?thesis by (rule Cons_parallelI2 [OF True ih])
  next
    case False
    then show ?thesis by (rule Cons_parallelI1)
  qed
qed

lemma suffix_reflclp_conv: "suffix\<^sup>=\<^sup>= = suffixeq"
  by (intro ext) (auto simp: suffixeq_def suffix_def)

lemma suffix_lists: "suffix xs ys \<Longrightarrow> ys \<in> lists A \<Longrightarrow> xs \<in> lists A"
  unfolding suffix_def by auto

subsection {* Homeomorphic embedding on lists *}

inductive list_emb :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  for P :: "('a \<Rightarrow> 'a \<Rightarrow> bool)"
where
  list_emb_Nil [intro, simp]: "list_emb P [] ys"
| list_emb_Cons [intro] : "list_emb P xs ys \<Longrightarrow> list_emb P xs (y#ys)"
| list_emb_Cons2 [intro]: "P x y \<Longrightarrow> list_emb P xs ys \<Longrightarrow> list_emb P (x#xs) (y#ys)"

lemma list_emb_mono:
  assumes "\<And>x y. P x y \<longrightarrow> Q x y"
  shows "list_emb P xs ys \<longrightarrow> list_emb Q xs ys"
proof
  assume "list_emb P xs ys"
  then show "list_emb Q xs ys" by (induct) (auto simp: assms)
qed

lemma list_emb_Nil2 [simp]:
  assumes "list_emb P xs []" shows "xs = []"
  using assms by (cases rule: list_emb.cases) auto

lemma list_emb_refl:
  assumes "\<And>x. x \<in> set xs \<Longrightarrow> P x x"
  shows "list_emb P xs xs"
  using assms by (induct xs) auto

lemma list_emb_Cons_Nil [simp]: "list_emb P (x#xs) [] = False"
proof -
  { assume "list_emb P (x#xs) []"
    from list_emb_Nil2 [OF this] have False by simp
  } moreover {
    assume False
    then have "list_emb P (x#xs) []" by simp
  } ultimately show ?thesis by blast
qed

lemma list_emb_append2 [intro]: "list_emb P xs ys \<Longrightarrow> list_emb P xs (zs @ ys)"
  by (induct zs) auto

lemma list_emb_prefix [intro]:
  assumes "list_emb P xs ys" shows "list_emb P xs (ys @ zs)"
  using assms
  by (induct arbitrary: zs) auto

lemma list_emb_ConsD:
  assumes "list_emb P (x#xs) ys"
  shows "\<exists>us v vs. ys = us @ v # vs \<and> P x v \<and> list_emb P xs vs"
using assms
proof (induct x \<equiv> "x # xs" ys arbitrary: x xs)
  case list_emb_Cons
  then show ?case by (metis append_Cons)
next
  case (list_emb_Cons2 x y xs ys)
  then show ?case by blast
qed

lemma list_emb_appendD:
  assumes "list_emb P (xs @ ys) zs"
  shows "\<exists>us vs. zs = us @ vs \<and> list_emb P xs us \<and> list_emb P ys vs"
using assms
proof (induction xs arbitrary: ys zs)
  case Nil then show ?case by auto
next
  case (Cons x xs)
  then obtain us v vs where
    zs: "zs = us @ v # vs" and p: "P x v" and lh: "list_emb P (xs @ ys) vs"
    by (auto dest: list_emb_ConsD)
  obtain sk\<^sub>0 :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" and sk\<^sub>1 :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
    sk: "\<forall>x\<^sub>0 x\<^sub>1. \<not> list_emb P (xs @ x\<^sub>0) x\<^sub>1 \<or> sk\<^sub>0 x\<^sub>0 x\<^sub>1 @ sk\<^sub>1 x\<^sub>0 x\<^sub>1 = x\<^sub>1 \<and> list_emb P xs (sk\<^sub>0 x\<^sub>0 x\<^sub>1) \<and> list_emb P x\<^sub>0 (sk\<^sub>1 x\<^sub>0 x\<^sub>1)"
    using Cons(1) by (metis (no_types))
  hence "\<forall>x\<^sub>2. list_emb P (x # xs) (x\<^sub>2 @ v # sk\<^sub>0 ys vs)" using p lh by auto
  thus ?case using lh zs sk by (metis (no_types) append_Cons append_assoc)
qed

lemma list_emb_suffix:
  assumes "list_emb P xs ys" and "suffix ys zs"
  shows "list_emb P xs zs"
  using assms(2) and list_emb_append2 [OF assms(1)] by (auto simp: suffix_def)

lemma list_emb_suffixeq:
  assumes "list_emb P xs ys" and "suffixeq ys zs"
  shows "list_emb P xs zs"
  using assms and list_emb_suffix unfolding suffixeq_suffix_reflclp_conv by auto

lemma list_emb_length: "list_emb P xs ys \<Longrightarrow> length xs \<le> length ys"
  by (induct rule: list_emb.induct) auto

lemma list_emb_trans:
  assumes "\<And>x y z. \<lbrakk>x \<in> set xs; y \<in> set ys; z \<in> set zs; P x y; P y z\<rbrakk> \<Longrightarrow> P x z"
  shows "\<lbrakk>list_emb P xs ys; list_emb P ys zs\<rbrakk> \<Longrightarrow> list_emb P xs zs"
proof -
  assume "list_emb P xs ys" and "list_emb P ys zs"
  then show "list_emb P xs zs" using assms
  proof (induction arbitrary: zs)
    case list_emb_Nil show ?case by blast
  next
    case (list_emb_Cons xs ys y)
    from list_emb_ConsD [OF `list_emb P (y#ys) zs`] obtain us v vs
      where zs: "zs = us @ v # vs" and "P\<^sup>=\<^sup>= y v" and "list_emb P ys vs" by blast
    then have "list_emb P ys (v#vs)" by blast
    then have "list_emb P ys zs" unfolding zs by (rule list_emb_append2)
    from list_emb_Cons.IH [OF this] and list_emb_Cons.prems show ?case by auto
  next
    case (list_emb_Cons2 x y xs ys)
    from list_emb_ConsD [OF `list_emb P (y#ys) zs`] obtain us v vs
      where zs: "zs = us @ v # vs" and "P y v" and "list_emb P ys vs" by blast
    with list_emb_Cons2 have "list_emb P xs vs" by auto
    moreover have "P x v"
    proof -
      from zs have "v \<in> set zs" by auto
      moreover have "x \<in> set (x#xs)" and "y \<in> set (y#ys)" by simp_all
      ultimately show ?thesis
        using `P x y` and `P y v` and list_emb_Cons2
        by blast
    qed
    ultimately have "list_emb P (x#xs) (v#vs)" by blast
    then show ?case unfolding zs by (rule list_emb_append2)
  qed
qed

lemma list_emb_set:
  assumes "list_emb P xs ys" and "x \<in> set xs"
  obtains y where "y \<in> set ys" and "P x y"
  using assms by (induct) auto

subsection {* Sublists (special case of homeomorphic embedding) *}

abbreviation sublisteq :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  where "sublisteq xs ys \<equiv> list_emb (op =) xs ys"

lemma sublisteq_Cons2: "sublisteq xs ys \<Longrightarrow> sublisteq (x#xs) (x#ys)" by auto

lemma sublisteq_same_length:
  assumes "sublisteq xs ys" and "length xs = length ys" shows "xs = ys"
  using assms by (induct) (auto dest: list_emb_length)

lemma not_sublisteq_length [simp]: "length ys < length xs \<Longrightarrow> \<not> sublisteq xs ys"
  by (metis list_emb_length linorder_not_less)

lemma sublisteq_Cons': "sublisteq (x#xs) ys \<Longrightarrow> sublisteq xs ys"
  by (induct xs, simp, blast dest: list_emb_ConsD)

lemma sublisteq_Cons2':
  assumes "sublisteq (x#xs) (x#ys)" shows "sublisteq xs ys"
  using assms by (cases) (rule sublisteq_Cons')

lemma sublisteq_Cons2_neq:
  assumes "sublisteq (x#xs) (y#ys)"
  shows "x \<noteq> y \<Longrightarrow> sublisteq (x#xs) ys"
  using assms by (cases) auto

lemma sublisteq_Cons2_iff [simp, code]:
  "sublisteq (x#xs) (y#ys) = (if x = y then sublisteq xs ys else sublisteq (x#xs) ys)"
  by (metis list_emb_Cons sublisteq_Cons2 sublisteq_Cons2' sublisteq_Cons2_neq)

lemma sublisteq_append': "sublisteq (zs @ xs) (zs @ ys) \<longleftrightarrow> sublisteq xs ys"
  by (induct zs) simp_all

lemma sublisteq_refl [simp, intro!]: "sublisteq xs xs" by (induct xs) simp_all

lemma sublisteq_antisym:
  assumes "sublisteq xs ys" and "sublisteq ys xs"
  shows "xs = ys"
using assms
proof (induct)
  case list_emb_Nil
  from list_emb_Nil2 [OF this] show ?case by simp
next
  case list_emb_Cons2
  thus ?case by simp
next
  case list_emb_Cons
  hence False using sublisteq_Cons' by fastforce
  thus ?case ..
qed

lemma sublisteq_trans: "sublisteq xs ys \<Longrightarrow> sublisteq ys zs \<Longrightarrow> sublisteq xs zs"
  by (rule list_emb_trans [of _ _ _ "op ="]) auto

lemma sublisteq_append_le_same_iff: "sublisteq (xs @ ys) ys \<longleftrightarrow> xs = []"
  by (auto dest: list_emb_length)

lemma list_emb_append_mono:
  "\<lbrakk> list_emb P xs xs'; list_emb P ys ys' \<rbrakk> \<Longrightarrow> list_emb P (xs@ys) (xs'@ys')"
  apply (induct rule: list_emb.induct)
    apply (metis eq_Nil_appendI list_emb_append2)
   apply (metis append_Cons list_emb_Cons)
  apply (metis append_Cons list_emb_Cons2)
  done

subsection {* Appending elements *}

lemma sublisteq_append [simp]:
  "sublisteq (xs @ zs) (ys @ zs) \<longleftrightarrow> sublisteq xs ys" (is "?l = ?r")
proof
  { fix xs' ys' xs ys zs :: "'a list" assume "sublisteq xs' ys'"
    then have "xs' = xs @ zs & ys' = ys @ zs \<longrightarrow> sublisteq xs ys"
    proof (induct arbitrary: xs ys zs)
      case list_emb_Nil show ?case by simp
    next
      case (list_emb_Cons xs' ys' x)
      { assume "ys=[]" then have ?case using list_emb_Cons(1) by auto }
      moreover
      { fix us assume "ys = x#us"
        then have ?case using list_emb_Cons(2) by(simp add: list_emb.list_emb_Cons) }
      ultimately show ?case by (auto simp:Cons_eq_append_conv)
    next
      case (list_emb_Cons2 x y xs' ys')
      { assume "xs=[]" then have ?case using list_emb_Cons2(1) by auto }
      moreover
      { fix us vs assume "xs=x#us" "ys=x#vs" then have ?case using list_emb_Cons2 by auto}
      moreover
      { fix us assume "xs=x#us" "ys=[]" then have ?case using list_emb_Cons2(2) by bestsimp }
      ultimately show ?case using `op = x y` by (auto simp: Cons_eq_append_conv)
    qed }
  moreover assume ?l
  ultimately show ?r by blast
next
  assume ?r then show ?l by (metis list_emb_append_mono sublisteq_refl)
qed

lemma sublisteq_drop_many: "sublisteq xs ys \<Longrightarrow> sublisteq xs (zs @ ys)"
  by (induct zs) auto

lemma sublisteq_rev_drop_many: "sublisteq xs ys \<Longrightarrow> sublisteq xs (ys @ zs)"
  by (metis append_Nil2 list_emb_Nil list_emb_append_mono)

subsection {* Relation to standard list operations *}

lemma sublisteq_map:
  assumes "sublisteq xs ys" shows "sublisteq (map f xs) (map f ys)"
  using assms by (induct) auto

lemma sublisteq_filter_left [simp]: "sublisteq (filter P xs) xs"
  by (induct xs) auto

lemma sublisteq_filter [simp]:
  assumes "sublisteq xs ys" shows "sublisteq (filter P xs) (filter P ys)"
  using assms by induct auto

lemma "sublisteq xs ys \<longleftrightarrow> (\<exists>N. xs = sublist ys N)" (is "?L = ?R")
proof
  assume ?L
  then show ?R
  proof (induct)
    case list_emb_Nil show ?case by (metis sublist_empty)
  next
    case (list_emb_Cons xs ys x)
    then obtain N where "xs = sublist ys N" by blast
    then have "xs = sublist (x#ys) (Suc ` N)"
      by (clarsimp simp add:sublist_Cons inj_image_mem_iff)
    then show ?case by blast
  next
    case (list_emb_Cons2 x y xs ys)
    then obtain N where "xs = sublist ys N" by blast
    then have "x#xs = sublist (x#ys) (insert 0 (Suc ` N))"
      by (clarsimp simp add:sublist_Cons inj_image_mem_iff)
    moreover from list_emb_Cons2 have "x = y" by simp
    ultimately show ?case by blast
  qed
next
  assume ?R
  then obtain N where "xs = sublist ys N" ..
  moreover have "sublisteq (sublist ys N) ys"
  proof (induct ys arbitrary: N)
    case Nil show ?case by simp
  next
    case Cons then show ?case by (auto simp: sublist_Cons)
  qed
  ultimately show ?L by simp
qed

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_58
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun zip :: "'a list => 'b list => (('a, 'b) pair) list" where
  "zip (nil2) y = nil2"
| "zip (cons2 z x2) (nil2) = nil2"
| "zip (cons2 z x2) (cons2 x3 x4) = cons2 (pair2 z x3) (zip x2 x4)"

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"

theorem property0 :
  "((drop n (zip xs ys)) = (zip (drop n xs) (drop n ys)))"
  apply(induct n arbitrary: xs ys)
   apply fastforce
    (*Why "case_tac xs"?
    Because of "drop (S n) xs" and "drop"'s pattern-matching.*)
  apply(case_tac xs)
   apply fastforce
  apply clarsimp
    (*Why "case_tac ys"?
    Because of "zip (cons2 x21 x22) ys" and "drop (S n) ys" and
    the pattern-matching of "zip" and "drop".*)
  apply(case_tac ys)
   apply clarsimp
    (*Why "case_tac "(TIP_prop_58.drop n x22)"?
     "zip (TIP_prop_58.drop n x22) nil2"*)
   apply(case_tac "(TIP_prop_58.drop n x22)")(*"case_tac" instead of "cases" because "\<And>n x2." *)
    apply fastforce+
  done

theorem property0':
  "((drop n (zip xs ys)) = (zip (drop n xs) (drop n ys)))"
  apply(induct n arbitrary: xs ys)
   apply fastforce
  apply(induct_tac xs)
   apply fastforce
  apply clarsimp
  apply(case_tac ys)
   apply clarsimp
   apply(case_tac "(TIP_prop_58.drop n x2)")(*"case_tac" instead of "cases" because "\<And>n x2." *)
    apply fastforce+
  done

theorem property0'' :(*alternative proof with sledgehammer.*)
  "((drop n (zip xs ys)) = (zip (drop n xs) (drop n ys)))"
  apply(induct n arbitrary: xs ys)
   apply fastforce
  apply(induct_tac xs)
   apply fastforce
  apply clarsimp
  apply(case_tac ys)
   apply clarsimp
   apply (metis TIP_prop_58.list.distinct(1) zip.elims)
  apply fastforce+
  done

end


(*<*)
(*
 * Knowledge-based programs.
 * (C)opyright 2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *
 * Based on Florian Haftmann's DList.thy and Tobias Nipkow's msort proofs.
 *)

theory ODList
imports
  "~~/src/HOL/Library/Multiset"
  List_local
begin
(*>*)

text{*

Define a type of ordered distinct lists, intended to represent sets.

The advantage of this representation is that it is isomorphic to the
set of finite sets. Conversely it requires the carrier type to be a
linear order.  Note that this representation does not arise from a
quotient on lists: all the unsorted lists are junk.

*}

context linorder
begin

text{*

"Absorbing" msort, a variant of Tobias Nipkow's proofs from 1992.

*}

fun
  merge :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "merge [] ys = ys"
| "merge xs [] = xs"
| "merge (x#xs) (y#ys) =
    (if x = y then merge xs (y#ys)
             else if x < y then x # merge xs (y#ys)
                           else y # merge (x#xs) ys)"

(*<*)
lemma set_merge[simp]:
  "set (merge xs ys) = set (xs @ ys)"
  by (induct xs ys rule: merge.induct) auto

lemma distinct_sorted_merge[simp]:
  "\<lbrakk> distinct xs; distinct ys; sorted xs; sorted ys \<rbrakk>
     \<Longrightarrow> distinct (merge xs ys) \<and> sorted (merge xs ys)"
  by (induct xs ys rule: merge.induct) (auto iff: sorted_Cons)

lemma multiset_of_merge [simp]:
  "\<lbrakk> distinct (xs @ ys) \<rbrakk> \<Longrightarrow> multiset_of (merge xs ys) = multiset_of xs + multiset_of ys"
  by (induct xs ys rule: merge.induct) (simp_all add: ac_simps)
(*>*)

text{* The "absorbing" sort itself. *}

fun msort :: "'a list \<Rightarrow> 'a list"
where
  "msort [] = []"
| "msort [x] = [x]"
| "msort xs = merge (msort (take (size xs div 2) xs))
                    (msort (drop (size xs div 2) xs))"

(*<*)
lemma msort_distinct_sorted[simp]:
  "distinct (msort xs) \<and> sorted (msort xs)"
  by (induct xs rule: msort.induct) simp_all

lemma msort_remdups[simp]:
  "remdups (msort xs) = msort xs"
  by simp

lemma msort_idle[simp]:
  "\<lbrakk> distinct xs; sorted xs \<rbrakk> \<Longrightarrow> msort xs = xs"
  by (rule map_sorted_distinct_set_unique[where f=id]) (auto simp: map.id)

lemma multiset_of_msort[simp]:
  "distinct xs \<Longrightarrow> multiset_of (msort xs) = multiset_of xs"
  by (rule iffD1[OF set_eq_iff_multiset_of_eq_distinct]) simp_all

lemma msort_sort[simp]:
  "distinct xs \<Longrightarrow> sort xs = msort xs"
  by (simp add: properties_for_sort)
(*>*)

end (* context linorder *)

section {* The @{term "odlist"} type *}

typedef ('a :: linorder) odlist = "{ x::'a list . sorted x \<and> distinct x }"
  morphisms toList odlist_Abs by auto

lemma distinct_toList[simp]: "distinct (toList xs)"
  using toList by auto

lemma sorted_toList[simp]: "sorted (toList xs)"
  using toList by auto

text{*

Code generator voodoo: this is the constructor for the abstract type.

*}

definition
  ODList :: "('a :: linorder) list \<Rightarrow> 'a odlist"
where
  "ODList \<equiv> odlist_Abs \<circ> msort"

lemma toList_ODList:
  "toList (ODList xs) = msort xs"
  unfolding ODList_def
  by (simp add: odlist_Abs_inverse)

lemma ODList_toList[simp, code abstype]:
  "ODList (toList xs) = xs"
  unfolding ODList_def
  by (cases xs) (simp add: odlist_Abs_inverse)

text{*

Runtime cast from @{typ "'a list"} into @{typ "'a odlist"}. This is
just a renaming of @{term "ODList"} -- names are significant to the
code generator's abstract type machinery.

*}

definition
  fromList :: "('a :: linorder) list \<Rightarrow> 'a odlist"
where
  "fromList \<equiv> ODList"

lemma toList_fromList[code abstract]:
  "toList (fromList xs) = msort xs"
  unfolding fromList_def
  by (simp add: toList_ODList)

subsection{* Basic properties: equality, finiteness *}

(*<*)
declare toList_inject[iff]
(*>*)

instantiation odlist :: (linorder) equal
(*<*)
begin

definition [code]:
  "HOL.equal A B \<longleftrightarrow> odlist_equal (toList A) (toList B)"

instance
  by default (simp add: equal_odlist_def)

end
(*>*)

instance odlist :: ("{finite, linorder}") finite
(*<*)
proof
  let ?ol = "UNIV :: 'a odlist set"
  let ?s = "UNIV :: 'a set set"
  have "finite ?s" by simp
  moreover
  have "?ol \<subseteq> range (odlist_Abs \<circ> sorted_list_of_set)"
  proof
    fix x show "x \<in> range (odlist_Abs \<circ> sorted_list_of_set)"
      apply (cases x)
      apply (rule range_eqI[where x="set (toList x)"])
      apply (clarsimp simp: odlist_Abs_inject sorted_list_of_set_sort_remdups odlist_Abs_inverse distinct_remdups_id)
      done
  qed
  ultimately show "finite ?ol" by (blast intro: finite_surj)
qed
(*>*)

subsection{* Constants *}

definition
  empty :: "('a :: linorder) odlist"
where
  "empty \<equiv> ODList []"

lemma toList_empty[simp, code abstract]:
  "toList empty = []"
  unfolding empty_def by (simp add: toList_ODList)

subsection{* Operations *}

subsubsection{* toSet *}

definition
  toSet :: "('a :: linorder) odlist \<Rightarrow> 'a set"
where
  "toSet X = set (toList X)"

lemma toSet_empty[simp]:
  "toSet empty = {}"
  unfolding toSet_def empty_def by (simp add: toList_ODList)

lemma toSet_ODList[simp]:
  "\<lbrakk> distinct xs; sorted xs \<rbrakk> \<Longrightarrow> toSet (ODList xs) = set xs"
  unfolding toSet_def by (simp add: toList_ODList)

lemma toSet_fromList_set[simp]:
  "toSet (fromList xs) = set xs"
  unfolding toSet_def fromList_def
  by (simp add: toList_ODList)

lemma toSet_inj[intro, simp]: "inj toSet"
  apply (rule injI)
  unfolding toSet_def
  apply (case_tac x)
  apply (case_tac y)
  apply (auto iff: odlist_Abs_inject odlist_Abs_inverse sorted_distinct_set_unique)
  done

lemma toSet_eq_iff:
  "X = Y \<longleftrightarrow> toSet X = toSet Y"
  by (blast dest: injD[OF toSet_inj])

subsubsection{* head *}

definition
  hd :: "('a :: linorder) odlist \<Rightarrow> 'a"
where
  [code]: "hd \<equiv> List.hd \<circ> toList"

lemma hd_toList: "toList xs = y # ys \<Longrightarrow> ODList.hd xs = y"
  unfolding hd_def by simp

subsubsection{* member *}

definition
  member :: "('a :: linorder) odlist \<Rightarrow> 'a \<Rightarrow> bool"
where
  [code]: "member xs x \<equiv> List.member (toList xs) x"

lemma member_toSet[iff]:
  "member xs x \<longleftrightarrow>x \<in> toSet xs"
  unfolding member_def toSet_def by (simp add: in_set_member)

subsubsection{* Filter *}

definition
  filter :: "(('a :: linorder) \<Rightarrow> bool) \<Rightarrow> 'a odlist \<Rightarrow> 'a odlist"
where
  "filter P xs \<equiv> ODList (List.filter P (toList xs))"

lemma toList_filter[simp, code abstract]:
  "toList (filter P xs) = List.filter P (toList xs)"
  unfolding filter_def by (simp add: toList_ODList)

lemma toSet_filter[simp]:
  "toSet (filter P xs) = { x \<in> toSet xs . P x }"
  unfolding filter_def
  apply simp
  apply (simp add: toSet_def)
  done

subsubsection{* All *}

definition
  odlist_all :: "('a :: linorder \<Rightarrow> bool) \<Rightarrow> 'a odlist \<Rightarrow> bool"
where
  [code]: "odlist_all P xs \<equiv> list_all P (toList xs)"

lemma odlist_all_cong [fundef_cong]:
  "xs = ys \<Longrightarrow> (\<And>x. x \<in> toSet ys \<Longrightarrow> f x = g x) \<Longrightarrow> odlist_all f xs = odlist_all g ys"
  by (simp add: odlist_all_iff)

subsubsection{* Difference *}

definition
  difference :: "('a :: linorder) odlist \<Rightarrow> 'a odlist \<Rightarrow> 'a odlist"
where
  "difference xs ys = ODList (List_local.difference (toList xs) (toList ys))"

lemma toList_difference[simp, code abstract]:
  "toList (difference xs ys) = List_local.difference (toList xs) (toList ys)"
  unfolding difference_def by (simp add: toList_ODList)

lemma toSet_difference[simp]:
  "toSet (difference xs ys) = toSet xs - toSet ys"
  unfolding difference_def
  apply simp
  apply (simp add: toSet_def)
  done

subsubsection{* Intersection *}

definition
  intersect :: "('a :: linorder) odlist \<Rightarrow> 'a odlist \<Rightarrow> 'a odlist"
where
  "intersect xs ys = ODList (List_local.intersection (toList xs) (toList ys))"

lemma toList_intersect[simp, code abstract]:
  "toList (intersect xs ys) = List_local.intersection (toList xs) (toList ys)"
  unfolding intersect_def by (simp add: toList_ODList)

subsubsection{* Union *}

definition
  union :: "('a :: linorder) odlist \<Rightarrow> 'a odlist \<Rightarrow> 'a odlist"
where
  "union xs ys = ODList (merge (toList xs) (toList ys))"

lemma toList_union[simp, code abstract]:
  "toList (union xs ys) = merge (toList xs) (toList ys)"
  unfolding union_def by (simp add: toList_ODList)

lemma toSet_union[simp]:
  "toSet (union xs ys) = toSet xs \<union> toSet ys"
  unfolding union_def
  apply simp
  apply (simp add: toSet_def)
  done

definition
  big_union :: "('b \<Rightarrow> ('a :: linorder) odlist) \<Rightarrow> 'b list \<Rightarrow> 'a odlist"
where
  [code]: "big_union f X \<equiv> foldr (\<lambda>a A. ODList.union (f a) A) X ODList.empty"

lemma toSet_big_union[simp]:
  "toSet (big_union f X) = (\<Union>x \<in> set X. toSet (f x))"
proof -
  { fix X Y
    have "toSet (foldr (\<lambda>x A. ODList.union (f x) A) X Y) = toSet Y \<union> (\<Union>x \<in> set X. toSet (f x))"
      by (induct X arbitrary: Y) auto }
   thus ?thesis
     unfolding big_union_def by simp
qed

subsubsection{* Case distinctions *}

text{*

We construct ODLists out of lists, so talk in terms of those, not a
one-step constructor we don't use.

*}

lemma distinct_sorted_induct [consumes 2, case_names Nil insert]:
  assumes "distinct xs"
  assumes "sorted xs"
  assumes base: "P []"
  assumes step: "\<And>x xs. \<lbrakk> distinct (x # xs); sorted (x # xs); P xs \<rbrakk> \<Longrightarrow> P (x # xs)"
  shows "P xs"
using `distinct xs` `sorted xs` proof (induct xs)
  case Nil from `P []` show ?case .
next
  case (Cons x xs)
  then have "distinct (x # xs)" and "sorted (x # xs)" and "P xs" by (simp_all add: sorted_Cons)
  with step show "P (x # xs)" .
qed

lemma odlist_induct [case_names empty insert, cases type: odlist]:
  assumes empty: "\<And>dxs. dxs = empty \<Longrightarrow> P dxs"
  assumes insrt: "\<And>dxs x xs. \<lbrakk> dxs = fromList (x # xs); distinct (x # xs); sorted (x # xs); P (fromList xs) \<rbrakk>
                            \<Longrightarrow> P dxs"
  shows "P dxs"
proof (cases dxs)
  case (odlist_Abs xs)
  then have dxs: "dxs = ODList xs" and distinct: "distinct xs" and sorted: "sorted xs"
    by (simp_all add: ODList_def)
  from `distinct xs` and `sorted xs` have "P (ODList xs)"
  proof (induct xs rule: distinct_sorted_induct)
    case Nil from empty show ?case by (simp add: empty_def)
  next
    case (insert x xs) thus ?case
      apply -
      apply (rule insrt)
      apply (auto iff: sorted_Cons fromList_def)
      done
  qed
  with dxs show "P dxs" by simp
qed

lemma odlist_cases [case_names empty insert, cases type: odlist]:
  assumes empty: "dxs = empty \<Longrightarrow> P"
  assumes insert: "\<And>x xs. \<lbrakk> dxs = fromList (x # xs); distinct (x # xs); sorted (x # xs) \<rbrakk>
                            \<Longrightarrow> P"
  shows P
proof (cases dxs)
  case (odlist_Abs xs)
  then have dxs: "dxs = ODList xs" and distinct: "distinct xs" and sorted: "sorted xs"
    by (simp_all add: ODList_def)
  show P proof (cases xs)
    case Nil with dxs have "dxs = empty" by (simp add: empty_def)
    with empty show P .
  next
    case (Cons y ys)
    with dxs distinct sorted insert
    show P by (simp add: fromList_def)
  qed
qed

subsubsection{* Relations *}

text{*

Relations, represented as a list of pairs.

*}

type_synonym 'a odrelation = "('a \<times> 'a) odlist"

subsubsection{* Image *}

text{*

The output of @{term "List_local.image"} is not guaranteed to be
ordered or distinct. Also the relation need not be monomorphic.

*}

definition
  image :: "('a :: linorder \<times> 'b :: linorder) odlist \<Rightarrow> 'a odlist \<Rightarrow> 'b odlist"
where
  "image R xs = ODList (List_local.image (toList R) (toList xs))"

lemma toList_image[simp, code abstract]:
  "toList (image R xs) = msort (List_local.image (toList R) (toList xs))"
  unfolding image_def by (simp add: toList_ODList)

lemma toSet_image[simp]:
  "toSet (image R xs) = toSet R `` toSet xs"
  unfolding image_def by (simp add: toSet_def toList_ODList)

subsubsection{* Linear order *}

text{*

Lexicographic ordering on lists. Executable, unlike in List.thy.

*}

instantiation odlist :: (linorder) linorder
begin
print_context
fun
  less_eq_list :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "less_eq_list [] ys = True"
| "less_eq_list xs [] = False"
| "less_eq_list (x # xs) (y # ys) = (x < y \<or> (x = y \<and> less_eq_list xs ys))"

lemma less_eq_list_nil_inv:
  fixes xs :: "'a list"
  shows "less_eq_list xs [] \<Longrightarrow> xs = []"
  by (cases xs) simp_all

lemma less_eq_list_cons_inv:
  fixes x :: 'a
  shows "less_eq_list (x # xs) yys \<Longrightarrow> \<exists>y ys. yys = y # ys \<and> (x < y \<or> (x = y \<and> less_eq_list xs ys))"
  by (cases yys) auto

lemma less_eq_list_refl:
  fixes xs :: "'a list"
  shows "less_eq_list xs xs"
  by (induct xs) simp_all

lemma less_eq_list_trans:
  fixes xs ys zs :: "'a list"
  shows "\<lbrakk> less_eq_list xs ys; less_eq_list ys zs \<rbrakk> \<Longrightarrow> less_eq_list xs zs"
  apply (induct xs ys arbitrary: zs rule: less_eq_list.induct)
    apply simp
   apply simp
  apply clarsimp
  apply (erule disjE)
   apply (drule less_eq_list_cons_inv)
   apply clarsimp
   apply (erule disjE)
    apply auto[1]
   apply auto[1]
  apply (auto dest: less_eq_list_cons_inv)
  done

lemma less_eq_list_antisym:
  fixes xs ys :: "'a list"
  shows "\<lbrakk> less_eq_list xs ys; less_eq_list ys xs \<rbrakk> \<Longrightarrow> xs = ys"
  by (induct xs ys rule: less_eq_list.induct) (auto dest: less_eq_list_nil_inv)

lemma less_eq_list_linear:
  fixes xs ys :: "'a list"
  shows "less_eq_list xs ys \<or> less_eq_list ys xs"
  by (induct xs ys rule: less_eq_list.induct) auto

definition
  less_eq_odlist :: "'a odlist \<Rightarrow> 'a odlist \<Rightarrow> bool"
where
  "xs \<le> ys \<equiv> less_eq_list (toList xs) (toList ys)"

fun
  less_list :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "less_list [] [] = False"
| "less_list [] ys = True"
| "less_list xs [] = False"
| "less_list (x # xs) (y # ys) = (x < y \<or> (x = y \<and> less_list xs ys))"

definition
  less_odlist :: "'a odlist \<Rightarrow> 'a odlist \<Rightarrow> bool"
where
  "xs < ys \<equiv> less_list (toList xs) (toList ys)"

lemma less_eq_list_not_le:
  fixes xs ys :: "'a list"
  shows "(less_list xs ys) = (less_eq_list xs ys \<and> \<not> less_eq_list ys xs)"
  by (induct xs ys rule: less_list.induct) auto

instance
  apply intro_classes
  unfolding less_eq_odlist_def less_odlist_def
  using less_eq_list_not_le less_eq_list_refl less_eq_list_trans less_eq_list_antisym
  apply blast
  using less_eq_list_not_le less_eq_list_refl less_eq_list_trans less_eq_list_antisym
  apply blast
  using less_eq_list_not_le less_eq_list_refl less_eq_list_trans less_eq_list_antisym
  apply blast
  using less_eq_list_not_le less_eq_list_refl less_eq_list_trans less_eq_list_antisym
  apply blast
  apply (rule less_eq_list_linear)
  done

end

subsubsection{* Finite maps *}

text{*

A few operations on finite maps.

Unlike the AssocList theory, ODLists give us canonical
representations, so we can order them. Our tabulate has the wrong type
(we want to take an odlist, not a list) so we can't use that
part of the framework.

*}

definition
  lookup :: "('a :: linorder \<times> 'b :: linorder) odlist \<Rightarrow> ('a \<rightharpoonup> 'b)"
where
  [code]: "lookup = map_of \<circ> toList"

text{* Specific to ODLists. *}

definition
  tabulate :: "('a :: linorder) odlist \<Rightarrow> ('a \<Rightarrow> 'b :: linorder) \<Rightarrow> ('a \<times> 'b) odlist"
where
  "tabulate ks f = ODList (List.map (\<lambda>k. (k, f k)) (toList ks))"

definition (in order) mono_on :: "('a \<Rightarrow> 'b\<Colon>order) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "mono_on f X \<longleftrightarrow> (\<forall>x\<in>X. \<forall>y\<in>X. x \<le> y \<longrightarrow> f x \<le> f y)"

lemma (in order) mono_onI [intro?]:
  fixes f :: "'a \<Rightarrow> 'b\<Colon>order"
  shows "(\<And>x y. x \<in> X \<Longrightarrow> y \<in> X \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> mono_on f X"
  unfolding mono_on_def by simp

lemma (in order) mono_onD [dest?]:
  fixes f :: "'a \<Rightarrow> 'b\<Colon>order"
  shows "mono_on f X \<Longrightarrow> x \<in> X \<Longrightarrow> y \<in> X \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
  unfolding mono_on_def by simp

lemma (in order) mono_on_subset:
  fixes f :: "'a \<Rightarrow> 'b\<Colon>order"
  shows "mono_on f X \<Longrightarrow> Y \<subseteq> X \<Longrightarrow> mono_on f Y"
  unfolding mono_on_def by auto

lemma sorted_mono_map:
  "\<lbrakk> sorted xs; mono_on f (set xs) \<rbrakk> \<Longrightarrow> sorted (List.map f xs)"
  apply (induct xs)
   apply simp
  apply (simp add: sorted_Cons)
  apply (cut_tac X="insert a (set xs)" and Y="set xs" in mono_on_subset)
  apply (auto dest: mono_onD)
  done

lemma msort_map:
  "\<lbrakk> distinct xs; sorted xs; inj_on f (set xs); mono_on f (set xs) \<rbrakk> \<Longrightarrow> msort (List.map f xs) = List.map f xs"
  apply (rule msort_idle)
   apply (simp add: distinct_map)
  apply (simp add: sorted_mono_map)
  done

lemma tabulate_toList[simp, code abstract]:
  "toList (tabulate ks f) = List.map (\<lambda>k. (k, f k)) (toList ks)"
  unfolding tabulate_def
  apply (simp add: toList_ODList)
  apply (subst msort_map)
  apply simp_all
   apply (rule inj_onI)
   apply simp
  apply (rule mono_onI)
  apply (simp add: less_eq_prod_def less_le)
  done

lemma lookup_tabulate[simp]:
  "lookup (tabulate ks f) = (Some o f) |` toSet ks"
proof(induct ks rule: odlist_induct)
  case (empty dxs) thus ?case unfolding tabulate_def lookup_def by (simp add: toList_ODList)
next
  case (insert dxs x xs)
  from insert have "map_of (List.map (\<lambda>k. (k, f k)) xs) = map_of (msort (List.map (\<lambda>k. (k, f k)) xs))"
    apply (subst msort_map)
    apply (auto intro: inj_onI simp: sorted_Cons)
    apply (rule mono_onI)
    apply (simp add: less_eq_prod_def less_le)
    done
  also from insert have "... = lookup (tabulate (fromList xs) f)"
    unfolding tabulate_def lookup_def
    by (simp add: toList_ODList toList_fromList sorted_Cons)
  also from insert have "... = (Some \<circ> f) |` toSet (fromList xs)"
    by (simp only: toSet_fromList_set)
  finally have IH: "map_of (List.map (\<lambda>k. (k, f k)) xs) = (Some \<circ> f) |` toSet (fromList xs)" .
  from insert have "lookup (tabulate dxs f) = map_of (toList (ODList (List.map (\<lambda>k. (k, f k)) (x # xs))))"
    unfolding tabulate_def lookup_def by (simp add: toList_fromList)
  also have "... = map_of (msort (List.map (\<lambda>k. (k, f k)) (x # xs)))"
    by (simp only: toList_ODList)
  also from insert have "... = map_of (List.map (\<lambda>k. (k, f k)) (x # xs))"
    apply (subst msort_map)
    apply (auto intro: inj_onI)
    apply (rule mono_onI)
    apply (simp add: less_eq_prod_def less_le)
    done
  also with insert IH have "... = (Some \<circ> f) |` toSet dxs"
    by (auto simp add: restrict_map_def fun_eq_iff)
  finally show ?case .
qed

(*<*)
end
(*>*)


(*
  File:     Periodic_Arithmetic.thy
  Authors:  Rodrigo Raya, EPFL; Manuel Eberl, TUM

  Periodic arithmetic functions
*)
section \<open>Periodic arithmetic functions\<close>
theory Periodic_Arithmetic
imports
  Complex_Main
  "HOL-Number_Theory.Cong"
begin

definition
  "periodic_arithmetic f k = (\<forall>n. f (n+k) = f n)"
  for n :: int and k :: nat and f :: "nat \<Rightarrow> complex"

lemma const_periodic_arithmetic: "periodic_arithmetic (\<lambda>x. y) k"
  unfolding periodic_arithmetic_def by blast

lemma add_periodic_arithmetic:
  fixes f g :: "nat \<Rightarrow> complex"
  assumes "periodic_arithmetic f k"
  assumes "periodic_arithmetic g k"
  shows "periodic_arithmetic (\<lambda>n. f n + g n) k"
  using assms unfolding periodic_arithmetic_def by simp

lemma mult_periodic_arithmetic:
  fixes f g :: "nat \<Rightarrow> complex"
  assumes "periodic_arithmetic f k"
  assumes "periodic_arithmetic g k"
  shows "periodic_arithmetic (\<lambda>n. f n * g n) k"
  using assms unfolding periodic_arithmetic_def  by simp

lemma scalar_mult_periodic_arithmetic:
  fixes f :: "nat \<Rightarrow> complex" and a :: complex
  assumes "periodic_arithmetic f k"
  shows "periodic_arithmetic (\<lambda>n. a * f n) k"
  using mult_periodic_arithmetic[OF const_periodic_arithmetic[of a k] assms(1)] by simp

lemma fin_sum_periodic_arithmetic_set:
  fixes f g :: "nat \<Rightarrow> complex"
  assumes "\<forall>i\<in>A. periodic_arithmetic (h i) k"
  shows "periodic_arithmetic (\<lambda>n. \<Sum>i \<in> A. h i n) k"
  using assms by (simp add: periodic_arithmetic_def)

lemma mult_period:
  assumes "periodic_arithmetic g k"
  shows "periodic_arithmetic g (k*q)"
  using assms
proof (induction q)
  case 0 then show ?case unfolding periodic_arithmetic_def by simp
next
  case (Suc m)
  then show ?case
    unfolding periodic_arithmetic_def
  proof -
   { fix n
     have "g (n + k * Suc m) = g (n + k +  k * m)"
       by (simp add: algebra_simps)
     also have "\<dots> = g(n)"
       using Suc.IH[OF Suc.prems] assms
       unfolding periodic_arithmetic_def by simp
     finally have "g (n + k * Suc m) = g(n)" by blast
   }
    then show "\<forall>n. g (n + k * Suc m) = g n" by auto
  qed
qed

lemma unique_periodic_arithmetic_extension:
  assumes "k > 0"
  assumes "\<forall>j<k. g j = h j"
  assumes "periodic_arithmetic g k" and "periodic_arithmetic h k"
  shows "g i = h i"
proof (cases "i < k")
  case True then show ?thesis using assms by simp
next
  case False then show ?thesis
  proof -
    have "k * (i div k) + (i mod k) = i \<and> (i mod k) < k"
      by (simp add: assms(1) algebra_simps)
    then obtain q r where euclid_div: "k*q + r = i \<and> r < k"
      using mult.commute by blast
    from assms(3) assms(4)
    have  "periodic_arithmetic g (k*q)" "periodic_arithmetic h (k*q)"
      using mult_period by simp+
    have "g(k*q+r) = g(r)"
      using \<open>periodic_arithmetic g (k*q)\<close> unfolding periodic_arithmetic_def
      using add.commute[of "k*q" r] by presburger
    also have "\<dots> = h(r)"
      using euclid_div assms(2) by simp
    also have "\<dots> = h(k*q+r)"
      using \<open>periodic_arithmetic h (k*q)\<close> add.commute[of "k*q" r]
      unfolding periodic_arithmetic_def by presburger
    also have "\<dots> = h(i)" using euclid_div by simp
    finally show "g(i) = h(i)" using euclid_div by simp
  qed
qed

lemma periodic_arithmetic_sum_periodic_arithmetic:
  assumes "periodic_arithmetic f k"
  shows "(\<Sum>l \<in> {m..n}. f l) = (\<Sum>l \<in> {m+k..n+k}. f l)"
  using periodic_arithmetic_def assms
  by (intro sum.reindex_bij_witness
         [of "{m..n}" "\<lambda>l. l-k" "\<lambda>l. l+k" "{m+k..n+k}" f f])
      auto

lemma mod_periodic_arithmetic:
  fixes n m :: nat
  assumes "periodic_arithmetic f k"
  assumes "n mod k = m mod k"
  shows "f n = f m"
proof -
  obtain q where 1: "n = q*k+(n mod k)"
     using div_mult_mod_eq[of n k,symmetric] by blast
  obtain q' where 2: "m = q'*k+(m mod k)"
     using div_mult_mod_eq[of m k,symmetric] by blast
  from 1 have "f n = f (q*k+(n mod k))" by auto
  also have "\<dots> = f (n mod k)"
    using mult_period[of f k q] assms(1) periodic_arithmetic_def[of f "k*q"]
    by (simp add: algebra_simps,subst add.commute,blast)
  also have "\<dots> = f (m mod k)" using assms(2) by auto
  also have "\<dots> = f (q'*k+(m mod k))"
    using mult_period[of f k q'] assms(1) periodic_arithmetic_def[of f "k*q'"]
    by (simp add: algebra_simps,subst add.commute,presburger)
  also have "\<dots> = f m" using 2 by auto
  finally show "f n = f m" by simp
qed

lemma cong_periodic_arithmetic:
  assumes "periodic_arithmetic f k" "[a = b] (mod k)"
  shows   "f a = f b"
  using assms mod_periodic_arithmetic[of f k a b] by (auto simp: cong_def)

lemma cong_nat_imp_eq:
  fixes m :: nat
  assumes "m > 0" "x \<in> {a..<a+m}" "y \<in> {a..<a+m}" "[x = y] (mod m)"
  shows   "x = y"
  using assms
proof (induction x y rule: linorder_wlog)
  case (le x y)
  have "[y - x = 0] (mod m)"
    using cong_diff_iff_cong_0_nat cong_sym le by blast
  thus "x = y"
    using le by (auto simp: cong_def)
qed (auto simp: cong_sym)

lemma inj_on_mod_nat:
  fixes m :: nat
  assumes "m > 0"
  shows   "inj_on (\<lambda>x. x mod m) {a..<a+m}"
proof
  fix x y assume xy: "x \<in> {a..<a+m}" "y \<in> {a..<a+m}" and eq: "x mod m = y mod m"
  from \<open>m > 0\<close> and xy show "x = y"
    by (rule cong_nat_imp_eq) (use eq in \<open>simp_all add: cong_def\<close>)
qed

lemma bij_betw_mod_nat_atLeastLessThan:
  fixes k d :: nat
  assumes "k > 0"
  defines "g \<equiv> (\<lambda>i. nat ((int i - int d) mod int k) + d)"
  shows   "bij_betw (\<lambda>i. i mod k) {d..<d+k} {..<k}"
  unfolding bij_betw_def
proof
  show inj: "inj_on (\<lambda>i. i mod k) {d..<d + k}"
    by (rule inj_on_mod_nat) fact+
  have "(\<lambda>i. i mod k) ` {d..<d + k} \<subseteq> {..<k}"
    by auto
  moreover have "card ((\<lambda>i. i mod k) ` {d..<d + k}) = card {..<k}"
    using inj by (subst card_image) auto
  ultimately show "(\<lambda>i. i mod k) ` {d..<d + k} = {..<k}"
    by (intro card_subset_eq) auto
qed

lemma periodic_arithmetic_sum_periodic_arithmetic_shift:
  fixes k d :: nat
  assumes "periodic_arithmetic f k" "k > 0" "d > 0"
  shows "(\<Sum>l \<in> {0..k-1}. f l) = (\<Sum>l \<in> {d..d+k-1}. f l)"
proof -
  have "(\<Sum>l \<in> {0..k-1}. f l) = (\<Sum>l \<in> {0..<k}. f l)"
    using assms(2) by (intro sum.cong) auto
  also have "\<dots> = (\<Sum>l \<in> {d..<d+k}. f (l mod k))"
    using assms(2)
    by (simp add: sum.reindex_bij_betw[OF bij_betw_mod_nat_atLeastLessThan[of k d]]
                  lessThan_atLeast0)
  also have "\<dots> = (\<Sum>l \<in> {d..<d+k}. f l)"
    using mod_periodic_arithmetic[of f k] assms(1) sum.cong
    by (meson mod_mod_trivial)
  also have "\<dots> = (\<Sum>l \<in> {d..d+k-1}. f l)"
    using assms(2,3) by (intro sum.cong) auto
  finally show ?thesis by auto
qed

lemma self_bij_0_k:
  fixes a k :: nat
  assumes "coprime a k" "[a*i = 1] (mod k)" "k > 0"
  shows "bij_betw (\<lambda>r. r*a mod k) {0..k-1} {0..k-1}"
  unfolding bij_betw_def
proof
  show "inj_on (\<lambda>r. r*a mod k) {0..k-1}"
  proof -
    {fix r1 r2
    assume in_k: "r1 \<in> {0..k-1}" "r2 \<in> {0..k-1}"
    assume as: "[r1*a = r2*a] (mod k)"
    then have "[r1*a*i = r2*a*i] (mod k)"
      using cong_scalar_right by blast
    then have "[r1 = r2] (mod k)"
      using cong_mult_rcancel_nat as assms(1) by simp
    then have "r1 = r2" using in_k
      using assms(3) cong_less_modulus_unique_nat by auto}
    note eq = this
    show ?thesis unfolding inj_on_def
      by (safe, simp add: eq cong_def)
  qed
  define f where "f = (\<lambda>r. r * a mod k)"
  show "f ` {0..k - 1} = {0..k - 1} "
    unfolding image_def
  proof (standard)
    show "{y. \<exists>x\<in>{0..k - 1}. y = f x} \<subseteq> {0..k - 1}"
    proof -
      {fix y
      assume "y \<in> {y. \<exists>x\<in>{0..k - 1}. y = f x}"
      then obtain x where "y = f x" by blast
      then have "y \<in> {0..k-1}"
        unfolding f_def
        using Suc_pred assms(3) lessThan_Suc_atMost by fastforce}
      then show ?thesis by blast
    qed
    show "{0..k - 1} \<subseteq> {y. \<exists>x\<in>{0..k - 1}. y = f x}"
    proof -
      { fix x
        assume ass: "x \<in> {0..k-1}"
        then have "x * i mod k \<in> {0..k-1}"
        proof -
          have "x * i mod k \<in> {0..<k}" by (simp add: assms(3))
          have "{0..<k} = {0..k-1}" using Suc_diff_1 assms(3) by auto
          show ?thesis using \<open>x * i mod k \<in> {0..<k}\<close> \<open>{0..<k} = {0..k-1}\<close> by blast
        qed
        then have "f (x * i mod k) = x"
        proof -
          have "f (x * i mod k) = (x * i mod k) * a mod k"
            unfolding f_def by blast
          also have "\<dots> = (x*i*a) mod k"
            by (simp add: mod_mult_left_eq)
          also have "\<dots> = (x*1) mod k"
            using assms(2)
            unfolding cong_def
            by (subst mult.assoc, subst (2) mult.commute,
               subst mod_mult_right_eq[symmetric],simp)
          also have "\<dots> = x" using ass assms(3) by auto
          finally show ?thesis .
        qed
        then have "x \<in> {y. \<exists>x\<in>{0..k - 1}. y = f x}"
          using \<open>x * i mod k \<in> {0..k-1}\<close> by force
      }
      then show ?thesis by blast
    qed
  qed
qed

lemma periodic_arithmetic_homothecy:
  assumes "periodic_arithmetic f k"
  shows   "periodic_arithmetic (\<lambda>l. f (l*a)) k"
  unfolding periodic_arithmetic_def
proof
  fix n
  have "f ((n + k) * a) = f(n*a+k*a)" by (simp add: algebra_simps)
  also have "\<dots> = f(n*a)"
    using mult_period[OF assms] unfolding periodic_arithmetic_def by simp
  finally show "f ((n + k) * a) = f (n * a)" by simp
qed

theorem periodic_arithmetic_remove_homothecy:
  assumes "coprime a k" "periodic_arithmetic f k" "k > 0"
  shows "(\<Sum>l=1..k. f l) = (\<Sum>l=1..k. f (l*a))"
proof -
  obtain i where inv: "[a*i = 1] (mod k)"
    using assms(1) coprime_iff_invertible_nat[of a k] by auto
  from this self_bij_0_k assms
  have bij: "bij_betw (\<lambda>r. r * a mod k) {0..k - 1} {0..k - 1}" by blast

  have "(\<Sum>l = 1..k. f(l)) = (\<Sum>l = 0..k-1. f(l))"
    using periodic_arithmetic_sum_periodic_arithmetic_shift[of f k 1] assms by simp
  also have "\<dots> = (\<Sum>l = 0..k-1. f(l*a mod k))"
    using sum.reindex_bij_betw[OF bij,symmetric] by blast
  also have "\<dots> = (\<Sum>l = 0..k-1. f(l*a))"
    by (intro sum.cong refl) (use mod_periodic_arithmetic[OF assms(2)] mod_mod_trivial in blast)
  also have "\<dots> = (\<Sum>l = 1..k. f(l*a))"
    using periodic_arithmetic_sum_periodic_arithmetic_shift[of "(\<lambda>l. f(l*a))" k 1]
          periodic_arithmetic_homothecy[OF assms(2)] assms(3) by fastforce
  finally show ?thesis by blast
qed

end


theory "chapter3"
  imports Main
begin

type_synonym vname = string

datatype aexp = N int | V vname | Plus aexp aexp

type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
  "aval (N n) s = n" |
  "aval (V x) s = s x" |
  "aval (Plus a1 a2) s = aval a1 s + aval a2 s"

value "aval (Plus (N 3) (V ''x'')) (\<lambda>x. 0)"

fun asimp_const :: "aexp \<Rightarrow> aexp" where
  "asimp_const (N n) = N n" |
  "asimp_const (V x) = V x" |
  "asimp_const (Plus a1 a2) =
    (case (asimp_const a1, asimp_const a2) of
      (N n1, N n2) \<Rightarrow> N (n1 + n2) |
      (b1, b2) \<Rightarrow> Plus b1 b2)"

(* asimp_const preserves evaluation *)
lemma "aval (asimp_const a) s = aval a s"
  apply (induction a)
  apply (auto split: aexp.split)
  done

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
  "plus (N n1) (N n2) = N (n1 + n2)" |
  "plus (N n) a = (if n = 0 then a else Plus (N n) a)" |
  "plus a (N n) = (if n = 0 then a else Plus a (N n))" |
  "plus a1 a2 = Plus a1 a2"

lemma aval_plus: "aval (plus a1 a2) s = aval a1 s + aval a2 s"
  apply (induction a1 rule: plus.induct)
  apply (induction a2 rule: plus.induct)
  apply auto
  done

fun asimp :: "aexp \<Rightarrow> aexp" where
  "asimp (N n) = N n" |
  "asimp (V x) = V x" |
  "asimp (Plus a1 a2) = plus (asimp a1) (asimp a2)"

(* asimp preserves evaluation *)
lemma "aval (asimp a) s = aval a s"
  apply (induction a)
  apply (auto simp: aval_plus)
  done

(* 3.1 *)
fun optimal :: "aexp \<Rightarrow> bool" where
  "optimal (N n) = True" |
  "optimal (V x) = True" |
  "optimal (Plus (N n1) (N n2)) = False" |
  "optimal (Plus a1 a2) = ((optimal a1) \<and> (optimal a2))"

theorem asimp_const_optimal: "optimal (asimp_const a)"
  apply (induction a)
  apply (auto split: aexp.split)
  done

(* 3.2 *)
fun var_aexp :: "aexp \<Rightarrow> aexp option" where
  "var_aexp (N n) = None" |
  "var_aexp (V x) = Some (V x)" |
  "var_aexp (Plus a1 a2) =
    (case (var_aexp a1, var_aexp a2) of
      (None, None) \<Rightarrow> None |
      (Some b1, None) \<Rightarrow> Some b1 |
      (None, Some b2) \<Rightarrow> Some b2 |
      (Some b1, Some b2) \<Rightarrow> Some (Plus b1 b2))"

fun fold_consts :: "aexp \<Rightarrow> aexp option" where
  "fold_consts (N n) = Some (N n)" |
  "fold_consts (V x) = None" |
  "fold_consts (Plus a1 a2) =
    (case (fold_consts a1, fold_consts a2) of
      (None, None) \<Rightarrow> None |
      (Some (N n1), None) \<Rightarrow> Some (N n1) |
      (None, Some (N n2)) \<Rightarrow> Some (N n2) |
      (Some (N n1), Some (N n2)) \<Rightarrow> Some (N (n1 + n2)))"

lemma "var_aexp a = None \<Longrightarrow> fold_consts a \<noteq> None"
  apply (induction a)
  apply auto
  apply (case_tac "var_aexp a1", case_tac "var_aexp a2")
  apply auto
  oops

(*
proof (prove)
goal (2 subgoals):
 1. \<And>a1 a2 y ya.
       var_aexp a1 = None \<Longrightarrow>
       var_aexp a2 = None \<Longrightarrow>
       fold_consts a1 = Some y \<Longrightarrow>
       fold_consts a2 = Some ya \<Longrightarrow>
       \<exists>ya. (case y of
             N n1 \<Rightarrow>
               case fold_consts a2 of None \<Rightarrow> Some (N n1)
               | Some (N n2) \<Rightarrow> Some (N (n1 + n2))) =
            Some ya
 2. \<And>a1 a2 a.
       (var_aexp a2 = None \<Longrightarrow> \<exists>y. fold_consts a2 = Some y) \<Longrightarrow>
       (case var_aexp a2 of None \<Rightarrow> Some a | Some b2 \<Rightarrow> Some (Plus a b2)) = None \<Longrightarrow>
       var_aexp a1 = Some a \<Longrightarrow>
       \<exists>y. (case fold_consts a1 of
            None \<Rightarrow> case fold_consts a2 of None \<Rightarrow> None | Some (N n2) \<Rightarrow> Some (N n2)
            | Some (N n1) \<Rightarrow>
                case fold_consts a2 of None \<Rightarrow> Some (N n1)
                | Some (N n2) \<Rightarrow> Some (N (n1 + n2))) =
           Some y
*)

lemma "fold_consts a = None \<Longrightarrow> var_aexp a \<noteq> None"
  oops

lemma "var_aexp a = None \<Longrightarrow> fold_consts a = None \<Longrightarrow> False"
  apply (induction a)
  oops

(* Acts like Plus but handles optional aexps *)
fun merge_aexps :: "aexp option \<Rightarrow> aexp option \<Rightarrow> aexp" where
  "merge_aexps None None = (N 0)" |
  "merge_aexps None (Some n) = n" |
  "merge_aexps (Some a) None = a" |
  "merge_aexps (Some a) (Some n) = Plus a n"

lemma "aval a s = aval (merge_aexps (var_aexp a) (fold_consts a)) s"
  apply (induction a)
  apply auto
  oops

fun full_asimp :: "aexp \<Rightarrow> aexp" where
  "full_asimp (N n) = N n" |
  "full_asimp (V x) = V x" |
  "full_asimp (Plus a1 a2) = merge_aexps (var_aexp (Plus a1 a2)) (fold_consts (Plus a1 a2))"

lemma "aval (full_asimp a) s = aval a s"
  apply (induction a)
  apply (auto split: aexp.split)
  oops

(*
fun full_plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
  (* Ways to combine two constants *)
  "full_plus (N n1) (N n2) = N (n1 + n2)" |
  "full_plus (Plus (N n1) a) (N n2) = Plus a (N (n1 + n2))" |
  "full_plus (Plus a (N n1)) (N n2) = Plus a (N (n1 + n2))" |
  "full_plus (N n1) (Plus (N n2) a) = Plus a (N (n1 + n2))" |
  "full_plus (N n1) (Plus a (N n2)) = Plus a (N (n1 + n2))" |
  (* Ways to shift constants right *)
  "full_plus (Plus a1 (N n1)) a2 = Plus (Plus a1 a2) (N n1)" |
  "full_plus a1 (Plus a2 (N n1)) = Plus (Plus a1 a2) (N n1)" |
  "full_plus (Plus (N n1) a1) (Plus (N n2) a2) = Plus (Plus a1 a2) (N (n1 + n2))" |
  (* Everything else *)
  "full_plus a1 a2 = Plus a1 a2"

lemma aval_full_plus: "aval (full_plus a1 a2) s = aval a1 s + aval a2 s"
  apply (induction rule: full_plus.induct)
  apply auto
  done

fun full_asimp :: "aexp \<Rightarrow> aexp" where
  "full_asimp (N n) = N n" |
  "full_asimp (V x) = V x" |
  "full_asimp (Plus a1 a2) = full_plus (full_asimp a1) (full_asimp a2)"

value "full_asimp (Plus (N 1) (Plus (V ''x'') (N 2)))"
value "full_asimp (Plus (N (- 2)) (Plus (N (- 1)) (V [])))"

lemma "aval (full_asimp a) s = aval a s"
  apply (induction a)
  apply (auto simp: aval_full_plus)
  done
*)

(* Great, we preserved that it doesn't change evaluation, but can we
  prove that it's also optimal?  *)

fun count_n :: "aexp \<Rightarrow> int" where
  "count_n (N n) = 1" |
  "count_n (V x) = 0" |
  "count_n (Plus a1 a2) = (count_n a1) + (count_n a2)"

(* Adding more cases to full_plus is making the evaluation take awhile. There has
  to be a better way to write the simplification rules for full_plus. *)
theorem full_asimp_optimal: "count_n (full_asimp a) \<le> 1"
  oops

end